FS/FS/Record.pm

   1 package FS::Record;
   2
   3 use strict;
   4 use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG
   5              $conf $conf_encryption $me
   6              %virtual_fields_cache
   7              $nowarn_identical $nowarn_classload
   8              $no_update_diff $no_check_foreign
   9            );
  10 use Exporter;
  11 use Carp qw(carp cluck croak confess);
  12 use Scalar::Util qw( blessed );
  13 use File::CounterFile;
  14 use Locale::Country;
  15 use Text::CSV_XS;
  16 use File::Slurp qw( slurp );
  17 use DBI qw(:sql_types);
  18 use DBIx::DBSchema 0.33;
  19 use FS::UID qw(dbh getotaker datasrc driver_name);
  20 use FS::CurrentUser;
  21 use FS::Schema qw(dbdef);
  22 use FS::SearchCache;
  23 use FS::Msgcat qw(gettext);
  24 #use FS::Conf; #dependency loop bs, in install_callback below instead
  25
  26 use FS::part_virtual_field;
  27
  28 use Tie::IxHash;
  29
  30 @ISA = qw(Exporter);
  31
  32 #export dbdef for now... everything else expects to find it here
  33 @EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef jsearch
  34                 str2time_sql str2time_sql_closing );
  35
  36 $DEBUG = 0;
  37 $me = '[FS::Record]';
  38
  39 $nowarn_identical = 0;
  40 $nowarn_classload = 0;
  41 $no_update_diff = 0;
  42 $no_check_foreign = 0;
  43
  44 my $rsa_module;
  45 my $rsa_loaded;
  46 my $rsa_encrypt;
  47 my $rsa_decrypt;
  48
  49 $conf = '';
  50 $conf_encryption = '';
  51 FS::UID->install_callback( sub {
  52   eval "use FS::Conf;";
  53   die $@ if $@;
  54   $conf = FS::Conf->new;
  55   $conf_encryption = $conf->exists('encryption');
  56   $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc;
  57 } );
  58
  59
  60 =head1 NAME
  61
  62 FS::Record - Database record objects
  63
  64 =head1 SYNOPSIS
  65
  66     use FS::Record;
  67     use FS::Record qw(dbh fields qsearch qsearchs);
  68
  69     $record = new FS::Record 'table', \%hash;
  70     $record = new FS::Record 'table', { 'column' => 'value', ... };
  71
  72     $record  = qsearchs FS::Record 'table', \%hash;
  73     $record  = qsearchs FS::Record 'table', { 'column' => 'value', ... };
  74     @records = qsearch  FS::Record 'table', \%hash;
  75     @records = qsearch  FS::Record 'table', { 'column' => 'value', ... };
  76
  77     $table = $record->table;
  78     $dbdef_table = $record->dbdef_table;
  79
  80     $value = $record->get('column');
  81     $value = $record->getfield('column');
  82     $value = $record->column;
  83
  84     $record->set( 'column' => 'value' );
  85     $record->setfield( 'column' => 'value' );
  86     $record->column('value');
  87
  88     %hash = $record->hash;
  89
  90     $hashref = $record->hashref;
  91
  92     $error = $record->insert;
  93
  94     $error = $record->delete;
  95
  96     $error = $new_record->replace($old_record);
  97
  98     # external use deprecated - handled by the database (at least for Pg, mysql)
  99     $value = $record->unique('column');
 100
 101     $error = $record->ut_float('column');
 102     $error = $record->ut_floatn('column');
 103     $error = $record->ut_number('column');
 104     $error = $record->ut_numbern('column');
 105     $error = $record->ut_snumber('column');
 106     $error = $record->ut_snumbern('column');
 107     $error = $record->ut_money('column');
 108     $error = $record->ut_text('column');
 109     $error = $record->ut_textn('column');
 110     $error = $record->ut_alpha('column');
 111     $error = $record->ut_alphan('column');
 112     $error = $record->ut_phonen('column');
 113     $error = $record->ut_anything('column');
 114     $error = $record->ut_name('column');
 115
 116     $quoted_value = _quote($value,'table','field');
 117
 118     #deprecated
 119     $fields = hfields('table');
 120     if ( $fields->{Field} ) { # etc.
 121
 122     @fields = fields 'table'; #as a subroutine
 123     @fields = $record->fields; #as a method call
 124
 125
 126 =head1 DESCRIPTION
 127
 128 (Mostly) object-oriented interface to database records.  Records are currently
 129 implemented on top of DBI.  FS::Record is intended as a base class for
 130 table-specific classes to inherit from, i.e. FS::cust_main.
 131
 132 =head1 CONSTRUCTORS
 133
 134 =over 4
 135
 136 =item new [ TABLE, ] HASHREF
 137
 138 Creates a new record.  It doesn't store it in the database, though.  See
 139 L<"insert"> for that.
 140
 141 Note that the object stores this hash reference, not a distinct copy of the
 142 hash it points to.  You can ask the object for a copy with the I<hash>
 143 method.
 144
 145 TABLE can only be omitted when a dervived class overrides the table method.
 146
 147 =cut
 148
 149 sub new {
 150   my $proto = shift;
 151   my $class = ref($proto) || $proto;
 152   my $self = {};
 153   bless ($self, $class);
 154
 155   unless ( defined ( $self->table ) ) {
 156     $self->{'Table'} = shift;
 157     carp "warning: FS::Record::new called with table name ". $self->{'Table'}
 158       unless $nowarn_classload;
 159   }
 160
 161   $self->{'Hash'} = shift;
 162
 163   foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {
 164     $self->{'Hash'}{$field}='';
 165   }
 166
 167   $self->_rebless if $self->can('_rebless');
 168
 169   $self->{'modified'} = 0;
 170
 171   $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
 172
 173   $self;
 174 }
 175
 176 sub new_or_cached {
 177   my $proto = shift;
 178   my $class = ref($proto) || $proto;
 179   my $self = {};
 180   bless ($self, $class);
 181
 182   $self->{'Table'} = shift unless defined ( $self->table );
 183
 184   my $hashref = $self->{'Hash'} = shift;
 185   my $cache = shift;
 186   if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) {
 187     my $obj = $cache->cache->{$hashref->{$cache->key}};
 188     $obj->_cache($hashref, $cache) if $obj->can('_cache');
 189     $obj;
 190   } else {
 191     $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache);
 192   }
 193
 194 }
 195
 196 sub create {
 197   my $proto = shift;
 198   my $class = ref($proto) || $proto;
 199   my $self = {};
 200   bless ($self, $class);
 201   if ( defined $self->table ) {
 202     cluck "create constructor is deprecated, use new!";
 203     $self->new(@_);
 204   } else {
 205     croak "FS::Record::create called (not from a subclass)!";
 206   }
 207 }
 208
 209 =item qsearch PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
 210
 211 Searches the database for all records matching (at least) the key/value pairs
 212 in HASHREF.  Returns all the records found as `FS::TABLE' objects if that
 213 module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
 214 objects.
 215
 216 The preferred usage is to pass a hash reference of named parameters:
 217
 218   @records = qsearch( {
 219                         'table'       => 'table_name',
 220                         'hashref'     => { 'field' => 'value'
 221                                            'field' => { 'op'    => '<',
 222                                                         'value' => '420',
 223                                                       },
 224                                          },
 225
 226                         #these are optional...
 227                         'select'      => '*',
 228                         'extra_sql'   => 'AND field = ? AND intfield = ?',
 229                         'extra_param' => [ 'value', [ 5, 'int' ] ],
 230                         'order_by'    => 'ORDER BY something',
 231                         #'cache_obj'   => '', #optional
 232                         'addl_from'   => 'LEFT JOIN othtable USING ( field )',
 233                         'debug'       => 1,
 234                       }
 235                     );
 236
 237 Much code still uses old-style positional parameters, this is also probably
 238 fine in the common case where there are only two parameters:
 239
 240   my @records = qsearch( 'table', { 'field' => 'value' } );
 241
 242 ###oops, argh, FS::Record::new only lets us create database fields.
 243 #Normal behaviour if SELECT is not specified is `*', as in
 244 #C<SELECT * FROM table WHERE ...>.  However, there is an experimental new
 245 #feature where you can specify SELECT - remember, the objects returned,
 246 #although blessed into the appropriate `FS::TABLE' package, will only have the
 247 #fields you specify.  This might have unwanted results if you then go calling
 248 #regular FS::TABLE methods
 249 #on it.
 250
 251 =cut
 252
 253 my %TYPE = (); #for debugging
 254
 255 sub _is_fs_float {
 256   my ($type, $value) = @_;
 257   if ( ( $type =~ /(numeric)/i && $value =~ /^[+-]?\d+(\.\d+)?$/ ) ||
 258        ( $type =~ /(real|float4)/i && $value =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/)
 259      ) {
 260     return 1;
 261   }
 262   '';
 263 }
 264
 265 sub qsearch {
 266   my($stable, $record, $cache );
 267   my( $select, $extra_sql, $extra_param, $order_by, $addl_from );
 268   my $debug = '';
 269   if ( ref($_[0]) ) { #hashref for now, eventually maybe accept a list too
 270     my $opt = shift;
 271     $stable      = $opt->{'table'}       or die "table name is required";
 272     $record      = $opt->{'hashref'}     || {};
 273     $select      = $opt->{'select'}      || '*';
 274     $extra_sql   = $opt->{'extra_sql'}   || '';
 275     $extra_param = $opt->{'extra_param'} || [];
 276     $order_by    = $opt->{'order_by'}    || '';
 277     $cache       = $opt->{'cache_obj'}   || '';
 278     $addl_from   = $opt->{'addl_from'}   || '';
 279     $debug       = $opt->{'debug'}       || '';
 280   } else {
 281     ($stable, $record, $select, $extra_sql, $cache, $addl_from ) = @_;
 282     $select ||= '*';
 283   }
 284
 285   #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
 286   #for jsearch
 287   $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
 288   $stable = $1;
 289   my $dbh = dbh;
 290
 291   my $table = $cache ? $cache->table : $stable;
 292   my $dbdef_table = dbdef->table($table)
 293     or die "No schema for table $table found - ".
 294            "do you need to run freeside-upgrade?";
 295   my $pkey = $dbdef_table->primary_key;
 296
 297   my @real_fields = grep exists($record->{$_}), real_fields($table);
 298   my @virtual_fields;
 299   if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
 300     @virtual_fields = grep exists($record->{$_}), "FS::$table"->virtual_fields;
 301   } else {
 302     cluck "warning: FS::$table not loaded; virtual fields not searchable"
 303       unless $nowarn_classload;
 304     @virtual_fields = ();
 305   }
 306
 307   my $statement = "SELECT $select FROM $stable";
 308   $statement .= " $addl_from" if $addl_from;
 309   if ( @real_fields or @virtual_fields ) {
 310     $statement .= ' WHERE '. join(' AND ',
 311       get_real_fields($table, $record, \@real_fields) ,
 312       get_virtual_fields($table, $pkey, $record, \@virtual_fields),
 313       );
 314   }
 315
 316   $statement .= " $extra_sql" if defined($extra_sql);
 317   $statement .= " $order_by"  if defined($order_by);
 318
 319   warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
 320   my $sth = $dbh->prepare($statement)
 321     or croak "$dbh->errstr doing $statement";
 322
 323   my $bind = 1;
 324
 325   foreach my $field (
 326     grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
 327   ) {
 328
 329     my $value = $record->{$field};
 330     my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
 331     $value = $value->{'value'} if ref($value);
 332     my $type = dbdef->table($table)->column($field)->type;
 333
 334     my $TYPE = SQL_VARCHAR;
 335     if ( $type =~ /(big)?(int|serial)/i && $value =~ /^\d+(\.\d+)?$/ ) {
 336       $TYPE = SQL_INTEGER;
 337
 338     #DBD::Pg 1.49: Cannot bind ... unknown sql_type 6 with SQL_FLOAT
 339     #fixed by DBD::Pg 2.11.8
 340     #can change back to SQL_FLOAT in early-mid 2010, once everyone's upgraded
 341     } elsif ( _is_fs_float( $type, $value ) ) {
 342       $TYPE = SQL_DECIMAL;
 343     }
 344
 345     if ( $DEBUG > 2 ) {
 346       no strict 'refs';
 347       %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
 348         unless keys %TYPE;
 349       warn "  bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
 350     }
 351
 352     #if this needs to be re-enabled, it needs to use a custom op like
 353     #"APPROX=" or something (better name?, not '=', to avoid affecting other
 354     # searches
 355     #if ($TYPE eq SQL_DECIMAL && $op eq 'APPROX=' ) {
 356     #  # these values are arbitrary; better (faster?) ones welcome
 357     #  $sth->bind_param($bind++, $value*1.00001, { TYPE => $TYPE } );
 358     #  $sth->bind_param($bind++, $value*.99999, { TYPE => $TYPE } );
 359     #} else {
 360       $sth->bind_param($bind++, $value, { TYPE => $TYPE } );
 361     #}
 362
 363   }
 364
 365   foreach my $param ( @$extra_param ) {
 366     my $TYPE = SQL_VARCHAR;
 367     my $value = $param;
 368     if ( ref($param) ) {
 369       $value = $param->[0];
 370       my $type = $param->[1];
 371       if ( $type =~ /(big)?(int|serial)/i && $value =~ /^\d+(\.\d+)?$/ ) {
 372         $TYPE = SQL_INTEGER;
 373       } # & DECIMAL?  well, who cares for now
 374     }
 375     $sth->bind_param($bind++, $value, { TYPE => $TYPE } );
 376   }
 377
 378 #  $sth->execute( map $record->{$_},
 379 #    grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
 380 #  ) or croak "Error executing \"$statement\": ". $sth->errstr;
 381
 382   $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
 383
 384   if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
 385     @virtual_fields = "FS::$table"->virtual_fields;
 386   } else {
 387     cluck "warning: FS::$table not loaded; virtual fields not returned either"
 388       unless $nowarn_classload;
 389     @virtual_fields = ();
 390   }
 391
 392   my %result;
 393   tie %result, "Tie::IxHash";
 394   my @stuff = @{ $sth->fetchall_arrayref( {} ) };
 395   if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
 396     %result = map { $_->{$pkey}, $_ } @stuff;
 397   } else {
 398     @result{@stuff} = @stuff;
 399   }
 400
 401   $sth->finish;
 402
 403   if ( keys(%result) and @virtual_fields ) {
 404     $statement =
 405       "SELECT virtual_field.recnum, part_virtual_field.name, ".
 406              "virtual_field.value ".
 407       "FROM part_virtual_field JOIN virtual_field USING (vfieldpart) ".
 408       "WHERE part_virtual_field.dbtable = '$table' AND ".
 409       "virtual_field.recnum IN (".
 410       join(',', keys(%result)). ") AND part_virtual_field.name IN ('".
 411       join(q!', '!, @virtual_fields) . "')";
 412     warn "[debug]$me $statement\n" if $DEBUG > 1;
 413     $sth = $dbh->prepare($statement) or croak "$dbh->errstr doing $statement";
 414     $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
 415
 416     foreach (@{ $sth->fetchall_arrayref({}) }) {
 417       my $recnum = $_->{recnum};
 418       my $name = $_->{name};
 419       my $value = $_->{value};
 420       if (exists($result{$recnum})) {
 421         $result{$recnum}->{$name} = $value;
 422       }
 423     }
 424   }
 425   my @return;
 426   if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
 427     if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
 428       #derivied class didn't override new method, so this optimization is safe
 429       if ( $cache ) {
 430         @return = map {
 431           new_or_cached( "FS::$table", { %{$_} }, $cache )
 432         } values(%result);
 433       } else {
 434         @return = map {
 435           new( "FS::$table", { %{$_} } )
 436         } values(%result);
 437       }
 438     } else {
 439       #okay, its been tested
 440       # warn "untested code (class FS::$table uses custom new method)";
 441       @return = map {
 442         eval 'FS::'. $table. '->new( { %{$_} } )';
 443       } values(%result);
 444     }
 445
 446     # Check for encrypted fields and decrypt them.
 447    ## only in the local copy, not the cached object
 448     if ( $conf_encryption
 449          && eval 'defined(@FS::'. $table . '::encrypted_fields)' ) {
 450       foreach my $record (@return) {
 451         foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
 452           # Set it directly... This may cause a problem in the future...
 453           $record->setfield($field, $record->decrypt($record->getfield($field)));
 454         }
 455       }
 456     }
 457   } else {
 458     cluck "warning: FS::$table not loaded; returning FS::Record objects"
 459       unless $nowarn_classload;
 460     @return = map {
 461       FS::Record->new( $table, { %{$_} } );
 462     } values(%result);
 463   }
 464   return @return;
 465 }
 466
 467 ## makes this easier to read
 468
 469 sub get_virtual_fields {
 470    my $table = shift;
 471    my $pkey = shift;
 472    my $record = shift;
 473    my $virtual_fields = shift;
 474
 475    return
 476     ( map {
 477       my $op = '=';
 478       my $column = $_;
 479       if ( ref($record->{$_}) ) {
 480         $op = $record->{$_}{'op'} if $record->{$_}{'op'};
 481         if ( uc($op) eq 'ILIKE' ) {
 482           $op = 'LIKE';
 483           $record->{$_}{'value'} = lc($record->{$_}{'value'});
 484           $column = "LOWER($_)";
 485         }
 486         $record->{$_} = $record->{$_}{'value'};
 487       }
 488
 489       # ... EXISTS ( SELECT name, value FROM part_virtual_field
 490       #              JOIN virtual_field
 491       #              ON part_virtual_field.vfieldpart = virtual_field.vfieldpart
 492       #              WHERE recnum = svc_acct.svcnum
 493       #              AND (name, value) = ('egad', 'brain') )
 494
 495       my $value = $record->{$_};
 496
 497       my $subq;
 498
 499       $subq = ($value ? 'EXISTS ' : 'NOT EXISTS ') .
 500       "( SELECT part_virtual_field.name, virtual_field.value ".
 501       "FROM part_virtual_field JOIN virtual_field ".
 502       "ON part_virtual_field.vfieldpart = virtual_field.vfieldpart ".
 503       "WHERE virtual_field.recnum = ${table}.${pkey} ".
 504       "AND part_virtual_field.name = '${column}'".
 505       ($value ?
 506         " AND virtual_field.value ${op} '${value}'"
 507       : "") . ")";
 508       $subq;
 509
 510     } @{ $virtual_fields } ) ;
 511 }
 512
 513 sub get_real_fields {
 514   my $table = shift;
 515   my $record = shift;
 516   my $real_fields = shift;
 517
 518    ## this huge map was previously inline, just broke it out to help read the qsearch method, should be optimized for readability
 519       return (
 520       map {
 521
 522       my $op = '=';
 523       my $column = $_;
 524       my $type = dbdef->table($table)->column($column)->type;
 525       my $value = $record->{$column};
 526       $value = $value->{'value'} if ref($value);
 527       if ( ref($record->{$_}) ) {
 528         $op = $record->{$_}{'op'} if $record->{$_}{'op'};
 529         #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
 530         if ( uc($op) eq 'ILIKE' ) {
 531           $op = 'LIKE';
 532           $record->{$_}{'value'} = lc($record->{$_}{'value'});
 533           $column = "LOWER($_)";
 534         }
 535         $record->{$_} = $record->{$_}{'value'}
 536       }
 537
 538       if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
 539         if ( $op eq '=' ) {
 540           if ( driver_name eq 'Pg' ) {
 541             if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
 542               qq-( $column IS NULL )-;
 543             } else {
 544               qq-( $column IS NULL OR $column = '' )-;
 545             }
 546           } else {
 547             qq-( $column IS NULL OR $column = "" )-;
 548           }
 549         } elsif ( $op eq '!=' ) {
 550           if ( driver_name eq 'Pg' ) {
 551             if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
 552               qq-( $column IS NOT NULL )-;
 553             } else {
 554               qq-( $column IS NOT NULL AND $column != '' )-;
 555             }
 556           } else {
 557             qq-( $column IS NOT NULL AND $column != "" )-;
 558           }
 559         } else {
 560           if ( driver_name eq 'Pg' ) {
 561             qq-( $column $op '' )-;
 562           } else {
 563             qq-( $column $op "" )-;
 564           }
 565         }
 566       #if this needs to be re-enabled, it needs to use a custom op like
 567       #"APPROX=" or something (better name?, not '=', to avoid affecting other
 568       # searches
 569       #} elsif ( $op eq 'APPROX=' && _is_fs_float( $type, $value ) ) {
 570       #  ( "$column <= ?", "$column >= ?" );
 571       } else {
 572         "$column $op ?";
 573       }
 574     } @{ $real_fields } );
 575 }
 576
 577 =item by_key PRIMARY_KEY_VALUE
 578
 579 This is a class method that returns the record with the given primary key
 580 value.  This method is only useful in FS::Record subclasses.  For example:
 581
 582   my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
 583
 584 is equivalent to:
 585
 586   my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
 587
 588 =cut
 589
 590 sub by_key {
 591   my ($class, $pkey_value) = @_;
 592
 593   my $table = $class->table
 594     or croak "No table for $class found";
 595
 596   my $dbdef_table = dbdef->table($table)
 597     or die "No schema for table $table found - ".
 598            "do you need to create it or run dbdef-create?";
 599   my $pkey = $dbdef_table->primary_key
 600     or die "No primary key for table $table";
 601
 602   return qsearchs($table, { $pkey => $pkey_value });
 603 }
 604
 605 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
 606
 607 Experimental JOINed search method.  Using this method, you can execute a
 608 single SELECT spanning multiple tables, and cache the results for subsequent
 609 method calls.  Interface will almost definately change in an incompatible
 610 fashion.
 611
 612 Arguments:
 613
 614 =cut
 615
 616 sub jsearch {
 617   my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
 618   my $cache = FS::SearchCache->new( $ptable, $pkey );
 619   my %saw;
 620   ( $cache,
 621     grep { !$saw{$_->getfield($pkey)}++ }
 622       qsearch($table, $record, $select, $extra_sql, $cache )
 623   );
 624 }
 625
 626 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
 627
 628 Same as qsearch, except that if more than one record matches, it B<carp>s but
 629 returns the first.  If this happens, you either made a logic error in asking
 630 for a single item, or your data is corrupted.
 631
 632 =cut
 633
 634 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
 635   my $table = $_[0];
 636   my(@result) = qsearch(@_);
 637   cluck "warning: Multiple records in scalar search ($table)"
 638     if scalar(@result) > 1;
 639   #should warn more vehemently if the search was on a primary key?
 640   scalar(@result) ? ($result[0]) : ();
 641 }
 642
 643 =back
 644
 645 =head1 METHODS
 646
 647 =over 4
 648
 649 =item table
 650
 651 Returns the table name.
 652
 653 =cut
 654
 655 sub table {
 656 #  cluck "warning: FS::Record::table deprecated; supply one in subclass!";
 657   my $self = shift;
 658   $self -> {'Table'};
 659 }
 660
 661 =item dbdef_table
 662
 663 Returns the DBIx::DBSchema::Table object for the table.
 664
 665 =cut
 666
 667 sub dbdef_table {
 668   my($self)=@_;
 669   my($table)=$self->table;
 670   dbdef->table($table);
 671 }
 672
 673 =item primary_key
 674
 675 Returns the primary key for the table.
 676
 677 =cut
 678
 679 sub primary_key {
 680   my $self = shift;
 681   my $pkey = $self->dbdef_table->primary_key;
 682 }
 683
 684 =item get, getfield COLUMN
 685
 686 Returns the value of the column/field/key COLUMN.
 687
 688 =cut
 689
 690 sub get {
 691   my($self,$field) = @_;
 692   # to avoid "Use of unitialized value" errors
 693   if ( defined ( $self->{Hash}->{$field} ) ) {
 694     $self->{Hash}->{$field};
 695   } else {
 696     '';
 697   }
 698 }
 699 sub getfield {
 700   my $self = shift;
 701   $self->get(@_);
 702 }
 703
 704 =item set, setfield COLUMN, VALUE
 705
 706 Sets the value of the column/field/key COLUMN to VALUE.  Returns VALUE.
 707
 708 =cut
 709
 710 sub set {
 711   my($self,$field,$value) = @_;
 712   $self->{'modified'} = 1;
 713   $self->{'Hash'}->{$field} = $value;
 714 }
 715 sub setfield {
 716   my $self = shift;
 717   $self->set(@_);
 718 }
 719
 720 =item AUTLOADED METHODS
 721
 722 $record->column is a synonym for $record->get('column');
 723
 724 $record->column('value') is a synonym for $record->set('column','value');
 725
 726 =cut
 727
 728 # readable/safe
 729 sub AUTOLOAD {
 730   my($self,$value)=@_;
 731   my($field)=$AUTOLOAD;
 732   $field =~ s/.*://;
 733   if ( defined($value) ) {
 734     confess "errant AUTOLOAD $field for $self (arg $value)"
 735       unless blessed($self) && $self->can('setfield');
 736     $self->setfield($field,$value);
 737   } else {
 738     confess "errant AUTOLOAD $field for $self (no args)"
 739       unless blessed($self) && $self->can('getfield');
 740     $self->getfield($field);
 741   }
 742 }
 743
 744 # efficient
 745 #sub AUTOLOAD {
 746 #  my $field = $AUTOLOAD;
 747 #  $field =~ s/.*://;
 748 #  if ( defined($_[1]) ) {
 749 #    $_[0]->setfield($field, $_[1]);
 750 #  } else {
 751 #    $_[0]->getfield($field);
 752 #  }
 753 #}
 754
 755 =item hash
 756
 757 Returns a list of the column/value pairs, usually for assigning to a new hash.
 758
 759 To make a distinct duplicate of an FS::Record object, you can do:
 760
 761     $new = new FS::Record ( $old->table, { $old->hash } );
 762
 763 =cut
 764
 765 sub hash {
 766   my($self) = @_;
 767   confess $self. ' -> hash: Hash attribute is undefined'
 768     unless defined($self->{'Hash'});
 769   %{ $self->{'Hash'} };
 770 }
 771
 772 =item hashref
 773
 774 Returns a reference to the column/value hash.  This may be deprecated in the
 775 future; if there's a reason you can't just use the autoloaded or get/set
 776 methods, speak up.
 777
 778 =cut
 779
 780 sub hashref {
 781   my($self) = @_;
 782   $self->{'Hash'};
 783 }
 784
 785 =item modified
 786
 787 Returns true if any of this object's values have been modified with set (or via
 788 an autoloaded method).  Doesn't yet recognize when you retreive a hashref and
 789 modify that.
 790
 791 =cut
 792
 793 sub modified {
 794   my $self = shift;
 795   $self->{'modified'};
 796 }
 797
 798 =item select_for_update
 799
 800 Selects this record with the SQL "FOR UPDATE" command.  This can be useful as
 801 a mutex.
 802
 803 =cut
 804
 805 sub select_for_update {
 806   my $self = shift;
 807   my $primary_key = $self->primary_key;
 808   qsearchs( {
 809     'select'    => '*',
 810     'table'     => $self->table,
 811     'hashref'   => { $primary_key => $self->$primary_key() },
 812     'extra_sql' => 'FOR UPDATE',
 813   } );
 814 }
 815
 816 =item lock_table
 817
 818 Locks this table with a database-driver specific lock method.  This is used
 819 as a mutex in order to do a duplicate search.
 820
 821 For PostgreSQL, does "LOCK TABLE tablename IN SHARE ROW EXCLUSIVE MODE".
 822
 823 For MySQL, does a SELECT FOR UPDATE on the duplicate_lock table.
 824
 825 Errors are fatal; no useful return value.
 826
 827 Note: To use this method for new tables other than svc_acct and svc_phone,
 828 edit freeside-upgrade and add those tables to the duplicate_lock list.
 829
 830 =cut
 831
 832 sub lock_table {
 833   my $self = shift;
 834   my $table = $self->table;
 835
 836   warn "$me locking $table table\n" if $DEBUG;
 837
 838   if ( driver_name =~ /^Pg/i ) {
 839
 840     dbh->do("LOCK TABLE $table IN SHARE ROW EXCLUSIVE MODE")
 841       or die dbh->errstr;
 842
 843   } elsif ( driver_name =~ /^mysql/i ) {
 844
 845     dbh->do("SELECT * FROM duplicate_lock
 846                WHERE lockname = '$table'
 847                FOR UPDATE"
 848            ) or die dbh->errstr;
 849
 850   } else {
 851
 852     die "unknown database ". driver_name. "; don't know how to lock table";
 853
 854   }
 855
 856   warn "$me acquired $table table lock\n" if $DEBUG;
 857
 858 }
 859
 860 =item insert
 861
 862 Inserts this record to the database.  If there is an error, returns the error,
 863 otherwise returns false.
 864
 865 =cut
 866
 867 sub insert {
 868   my $self = shift;
 869   my $saved = {};
 870
 871   warn "$self -> insert" if $DEBUG;
 872
 873   my $error = $self->check;
 874   return $error if $error;
 875
 876   #single-field unique keys are given a value if false
 877   #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
 878   foreach ( $self->dbdef_table->unique_singles) {
 879     $self->unique($_) unless $self->getfield($_);
 880   }
 881
 882   #and also the primary key, if the database isn't going to
 883   my $primary_key = $self->dbdef_table->primary_key;
 884   my $db_seq = 0;
 885   if ( $primary_key ) {
 886     my $col = $self->dbdef_table->column($primary_key);
 887
 888     $db_seq =
 889       uc($col->type) =~ /^(BIG)?SERIAL\d?/
 890       || ( driver_name eq 'Pg'
 891              && defined($col->default)
 892              && $col->default =~ /^nextval\(/i
 893          )
 894       || ( driver_name eq 'mysql'
 895              && defined($col->local)
 896              && $col->local =~ /AUTO_INCREMENT/i
 897          );
 898     $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
 899   }
 900
 901   my $table = $self->table;
 902
 903   # Encrypt before the database
 904   if (    defined(eval '@FS::'. $table . '::encrypted_fields')
 905        && scalar( eval '@FS::'. $table . '::encrypted_fields')
 906        && $conf->exists('encryption')
 907   ) {
 908     foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
 909       $self->{'saved'} = $self->getfield($field);
 910       $self->setfield($field, $self->encrypt($self->getfield($field)));
 911     }
 912   }
 913
 914   #false laziness w/delete
 915   my @real_fields =
 916     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
 917     real_fields($table)
 918   ;
 919   my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
 920   #eslaf
 921
 922   my $statement = "INSERT INTO $table ";
 923   if ( @real_fields ) {
 924     $statement .=
 925       "( ".
 926         join( ', ', @real_fields ).
 927       ") VALUES (".
 928         join( ', ', @values ).
 929        ")"
 930     ;
 931   } else {
 932     $statement .= 'DEFAULT VALUES';
 933   }
 934   warn "[debug]$me $statement\n" if $DEBUG > 1;
 935   my $sth = dbh->prepare($statement) or return dbh->errstr;
 936
 937   local $SIG{HUP} = 'IGNORE';
 938   local $SIG{INT} = 'IGNORE';
 939   local $SIG{QUIT} = 'IGNORE';
 940   local $SIG{TERM} = 'IGNORE';
 941   local $SIG{TSTP} = 'IGNORE';
 942   local $SIG{PIPE} = 'IGNORE';
 943
 944   $sth->execute or return $sth->errstr;
 945
 946   # get inserted id from the database, if applicable & needed
 947   if ( $db_seq && ! $self->getfield($primary_key) ) {
 948     warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
 949
 950     my $insertid = '';
 951
 952     if ( driver_name eq 'Pg' ) {
 953
 954       #my $oid = $sth->{'pg_oid_status'};
 955       #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
 956
 957       my $default = $self->dbdef_table->column($primary_key)->default;
 958       unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
 959         dbh->rollback if $FS::UID::AutoCommit;
 960         return "can't parse $table.$primary_key default value".
 961                " for sequence name: $default";
 962       }
 963       my $sequence = $1;
 964
 965       my $i_sql = "SELECT currval('$sequence')";
 966       my $i_sth = dbh->prepare($i_sql) or do {
 967         dbh->rollback if $FS::UID::AutoCommit;
 968         return dbh->errstr;
 969       };
 970       $i_sth->execute() or do { #$i_sth->execute($oid)
 971         dbh->rollback if $FS::UID::AutoCommit;
 972         return $i_sth->errstr;
 973       };
 974       $insertid = $i_sth->fetchrow_arrayref->[0];
 975
 976     } elsif ( driver_name eq 'mysql' ) {
 977
 978       $insertid = dbh->{'mysql_insertid'};
 979       # work around mysql_insertid being null some of the time, ala RT :/
 980       unless ( $insertid ) {
 981         warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
 982              "using SELECT LAST_INSERT_ID();";
 983         my $i_sql = "SELECT LAST_INSERT_ID()";
 984         my $i_sth = dbh->prepare($i_sql) or do {
 985           dbh->rollback if $FS::UID::AutoCommit;
 986           return dbh->errstr;
 987         };
 988         $i_sth->execute or do {
 989           dbh->rollback if $FS::UID::AutoCommit;
 990           return $i_sth->errstr;
 991         };
 992         $insertid = $i_sth->fetchrow_arrayref->[0];
 993       }
 994
 995     } else {
 996
 997       dbh->rollback if $FS::UID::AutoCommit;
 998       return "don't know how to retreive inserted ids from ". driver_name.
 999              ", try using counterfiles (maybe run dbdef-create?)";
1000
1001     }
1002
1003     $self->setfield($primary_key, $insertid);
1004
1005   }
1006
1007   my @virtual_fields =
1008       grep defined($self->getfield($_)) && $self->getfield($_) ne "",
1009           $self->virtual_fields;
1010   if (@virtual_fields) {
1011     my %v_values = map { $_, $self->getfield($_) } @virtual_fields;
1012
1013     my $vfieldpart = $self->vfieldpart_hashref;
1014
1015     my $v_statement = "INSERT INTO virtual_field(recnum, vfieldpart, value) ".
1016                     "VALUES (?, ?, ?)";
1017
1018     my $v_sth = dbh->prepare($v_statement) or do {
1019       dbh->rollback if $FS::UID::AutoCommit;
1020       return dbh->errstr;
1021     };
1022
1023     foreach (keys(%v_values)) {
1024       $v_sth->execute($self->getfield($primary_key),
1025                       $vfieldpart->{$_},
1026                       $v_values{$_})
1027       or do {
1028         dbh->rollback if $FS::UID::AutoCommit;
1029         return $v_sth->errstr;
1030       };
1031     }
1032   }
1033
1034
1035   my $h_sth;
1036   if ( defined dbdef->table('h_'. $table) ) {
1037     my $h_statement = $self->_h_statement('insert');
1038     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1039     $h_sth = dbh->prepare($h_statement) or do {
1040       dbh->rollback if $FS::UID::AutoCommit;
1041       return dbh->errstr;
1042     };
1043   } else {
1044     $h_sth = '';
1045   }
1046   $h_sth->execute or return $h_sth->errstr if $h_sth;
1047
1048   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1049
1050   # Now that it has been saved, reset the encrypted fields so that $new
1051   # can still be used.
1052   foreach my $field (keys %{$saved}) {
1053     $self->setfield($field, $saved->{$field});
1054   }
1055
1056   '';
1057 }
1058
1059 =item add
1060
1061 Depriciated (use insert instead).
1062
1063 =cut
1064
1065 sub add {
1066   cluck "warning: FS::Record::add deprecated!";
1067   insert @_; #call method in this scope
1068 }
1069
1070 =item delete
1071
1072 Delete this record from the database.  If there is an error, returns the error,
1073 otherwise returns false.
1074
1075 =cut
1076
1077 sub delete {
1078   my $self = shift;
1079
1080   my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
1081     map {
1082       $self->getfield($_) eq ''
1083         #? "( $_ IS NULL OR $_ = \"\" )"
1084         ? ( driver_name eq 'Pg'
1085               ? "$_ IS NULL"
1086               : "( $_ IS NULL OR $_ = \"\" )"
1087           )
1088         : "$_ = ". _quote($self->getfield($_),$self->table,$_)
1089     } ( $self->dbdef_table->primary_key )
1090           ? ( $self->dbdef_table->primary_key)
1091           : real_fields($self->table)
1092   );
1093   warn "[debug]$me $statement\n" if $DEBUG > 1;
1094   my $sth = dbh->prepare($statement) or return dbh->errstr;
1095
1096   my $h_sth;
1097   if ( defined dbdef->table('h_'. $self->table) ) {
1098     my $h_statement = $self->_h_statement('delete');
1099     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1100     $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
1101   } else {
1102     $h_sth = '';
1103   }
1104
1105   my $primary_key = $self->dbdef_table->primary_key;
1106   my $v_sth;
1107   my @del_vfields;
1108   my $vfp = $self->vfieldpart_hashref;
1109   foreach($self->virtual_fields) {
1110     next if $self->getfield($_) eq '';
1111     unless(@del_vfields) {
1112       my $st = "DELETE FROM virtual_field WHERE recnum = ? AND vfieldpart = ?";
1113       $v_sth = dbh->prepare($st) or return dbh->errstr;
1114     }
1115     push @del_vfields, $_;
1116   }
1117
1118   local $SIG{HUP} = 'IGNORE';
1119   local $SIG{INT} = 'IGNORE';
1120   local $SIG{QUIT} = 'IGNORE';
1121   local $SIG{TERM} = 'IGNORE';
1122   local $SIG{TSTP} = 'IGNORE';
1123   local $SIG{PIPE} = 'IGNORE';
1124
1125   my $rc = $sth->execute or return $sth->errstr;
1126   #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1127   $h_sth->execute or return $h_sth->errstr if $h_sth;
1128   $v_sth->execute($self->getfield($primary_key), $vfp->{$_})
1129     or return $v_sth->errstr
1130         foreach (@del_vfields);
1131
1132   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1133
1134   #no need to needlessly destoy the data either (causes problems actually)
1135   #undef $self; #no need to keep object!
1136
1137   '';
1138 }
1139
1140 =item del
1141
1142 Depriciated (use delete instead).
1143
1144 =cut
1145
1146 sub del {
1147   cluck "warning: FS::Record::del deprecated!";
1148   &delete(@_); #call method in this scope
1149 }
1150
1151 =item replace OLD_RECORD
1152
1153 Replace the OLD_RECORD with this one in the database.  If there is an error,
1154 returns the error, otherwise returns false.
1155
1156 =cut
1157
1158 sub replace {
1159   my ($new, $old) = (shift, shift);
1160
1161   $old = $new->replace_old unless defined($old);
1162
1163   warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1164
1165   if ( $new->can('replace_check') ) {
1166     my $error = $new->replace_check($old);
1167     return $error if $error;
1168   }
1169
1170   return "Records not in same table!" unless $new->table eq $old->table;
1171
1172   my $primary_key = $old->dbdef_table->primary_key;
1173   return "Can't change primary key $primary_key ".
1174          'from '. $old->getfield($primary_key).
1175          ' to ' . $new->getfield($primary_key)
1176     if $primary_key
1177        && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1178
1179   my $error = $new->check;
1180   return $error if $error;
1181
1182   # Encrypt for replace
1183   my $saved = {};
1184   if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . '::encrypted_fields')) {
1185     foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1186       $saved->{$field} = $new->getfield($field);
1187       $new->setfield($field, $new->encrypt($new->getfield($field)));
1188     }
1189   }
1190
1191   #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1192   my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1193                    ? ($_, $new->getfield($_)) : () } $old->fields;
1194
1195   unless (keys(%diff) || $no_update_diff ) {
1196     carp "[warning]$me $new -> replace $old: records identical"
1197       unless $nowarn_identical;
1198     return '';
1199   }
1200
1201   my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1202     map {
1203       "$_ = ". _quote($new->getfield($_),$old->table,$_)
1204     } real_fields($old->table)
1205   ). ' WHERE '.
1206     join(' AND ',
1207       map {
1208
1209         if ( $old->getfield($_) eq '' ) {
1210
1211          #false laziness w/qsearch
1212          if ( driver_name eq 'Pg' ) {
1213             my $type = $old->dbdef_table->column($_)->type;
1214             if ( $type =~ /(int|(big)?serial)/i ) {
1215               qq-( $_ IS NULL )-;
1216             } else {
1217               qq-( $_ IS NULL OR $_ = '' )-;
1218             }
1219           } else {
1220             qq-( $_ IS NULL OR $_ = "" )-;
1221           }
1222
1223         } else {
1224           "$_ = ". _quote($old->getfield($_),$old->table,$_);
1225         }
1226
1227       } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1228     )
1229   ;
1230   warn "[debug]$me $statement\n" if $DEBUG > 1;
1231   my $sth = dbh->prepare($statement) or return dbh->errstr;
1232
1233   my $h_old_sth;
1234   if ( defined dbdef->table('h_'. $old->table) ) {
1235     my $h_old_statement = $old->_h_statement('replace_old');
1236     warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1237     $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1238   } else {
1239     $h_old_sth = '';
1240   }
1241
1242   my $h_new_sth;
1243   if ( defined dbdef->table('h_'. $new->table) ) {
1244     my $h_new_statement = $new->_h_statement('replace_new');
1245     warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1246     $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1247   } else {
1248     $h_new_sth = '';
1249   }
1250
1251   # For virtual fields we have three cases with different SQL
1252   # statements: add, replace, delete
1253   my $v_add_sth;
1254   my $v_rep_sth;
1255   my $v_del_sth;
1256   my (@add_vfields, @rep_vfields, @del_vfields);
1257   my $vfp = $old->vfieldpart_hashref;
1258   foreach(grep { exists($diff{$_}) } $new->virtual_fields) {
1259     if($diff{$_} eq '') {
1260       # Delete
1261       unless(@del_vfields) {
1262         my $st = "DELETE FROM virtual_field WHERE recnum = ? ".
1263                  "AND vfieldpart = ?";
1264         warn "[debug]$me $st\n" if $DEBUG > 2;
1265         $v_del_sth = dbh->prepare($st) or return dbh->errstr;
1266       }
1267       push @del_vfields, $_;
1268     } elsif($old->getfield($_) eq '') {
1269       # Add
1270       unless(@add_vfields) {
1271         my $st = "INSERT INTO virtual_field (value, recnum, vfieldpart) ".
1272                  "VALUES (?, ?, ?)";
1273         warn "[debug]$me $st\n" if $DEBUG > 2;
1274         $v_add_sth = dbh->prepare($st) or return dbh->errstr;
1275       }
1276       push @add_vfields, $_;
1277     } else {
1278       # Replace
1279       unless(@rep_vfields) {
1280         my $st = "UPDATE virtual_field SET value = ? ".
1281                  "WHERE recnum = ? AND vfieldpart = ?";
1282         warn "[debug]$me $st\n" if $DEBUG > 2;
1283         $v_rep_sth = dbh->prepare($st) or return dbh->errstr;
1284       }
1285       push @rep_vfields, $_;
1286     }
1287   }
1288
1289   local $SIG{HUP} = 'IGNORE';
1290   local $SIG{INT} = 'IGNORE';
1291   local $SIG{QUIT} = 'IGNORE';
1292   local $SIG{TERM} = 'IGNORE';
1293   local $SIG{TSTP} = 'IGNORE';
1294   local $SIG{PIPE} = 'IGNORE';
1295
1296   my $rc = $sth->execute or return $sth->errstr;
1297   #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1298   $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1299   $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1300
1301   $v_del_sth->execute($old->getfield($primary_key),
1302                       $vfp->{$_})
1303         or return $v_del_sth->errstr
1304       foreach(@del_vfields);
1305
1306   $v_add_sth->execute($new->getfield($_),
1307                       $old->getfield($primary_key),
1308                       $vfp->{$_})
1309         or return $v_add_sth->errstr
1310       foreach(@add_vfields);
1311
1312   $v_rep_sth->execute($new->getfield($_),
1313                       $old->getfield($primary_key),
1314                       $vfp->{$_})
1315         or return $v_rep_sth->errstr
1316       foreach(@rep_vfields);
1317
1318   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1319
1320   # Now that it has been saved, reset the encrypted fields so that $new
1321   # can still be used.
1322   foreach my $field (keys %{$saved}) {
1323     $new->setfield($field, $saved->{$field});
1324   }
1325
1326   '';
1327
1328 }
1329
1330 sub replace_old {
1331   my( $self ) = shift;
1332   warn "[$me] replace called with no arguments; autoloading old record\n"
1333     if $DEBUG;
1334
1335   my $primary_key = $self->dbdef_table->primary_key;
1336   if ( $primary_key ) {
1337     $self->by_key( $self->$primary_key() ) #this is what's returned
1338       or croak "can't find ". $self->table. ".$primary_key ".
1339         $self->$primary_key();
1340   } else {
1341     croak $self->table. " has no primary key; pass old record as argument";
1342   }
1343
1344 }
1345
1346 =item rep
1347
1348 Depriciated (use replace instead).
1349
1350 =cut
1351
1352 sub rep {
1353   cluck "warning: FS::Record::rep deprecated!";
1354   replace @_; #call method in this scope
1355 }
1356
1357 =item check
1358
1359 Checks virtual fields (using check_blocks).  Subclasses should still provide
1360 a check method to validate real fields, foreign keys, etc., and call this
1361 method via $self->SUPER::check.
1362
1363 (FIXME: Should this method try to make sure that it I<is> being called from
1364 a subclass's check method, to keep the current semantics as far as possible?)
1365
1366 =cut
1367
1368 sub check {
1369   #confess "FS::Record::check not implemented; supply one in subclass!";
1370   my $self = shift;
1371
1372   foreach my $field ($self->virtual_fields) {
1373     for ($self->getfield($field)) {
1374       # See notes on check_block in FS::part_virtual_field.
1375       eval $self->pvf($field)->check_block;
1376       if ( $@ ) {
1377         #this is bad, probably want to follow the stack backtrace up and see
1378         #wtf happened
1379         my $err = "Fatal error checking $field for $self";
1380         cluck "$err: $@";
1381         return "$err (see log for backtrace): $@";
1382
1383       }
1384       $self->setfield($field, $_);
1385     }
1386   }
1387   '';
1388 }
1389
1390 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
1391
1392 Processes a batch import as a queued JSRPC job
1393
1394 JOB is an FS::queue entry.
1395
1396 OPTIONS_HASHREF can have the following keys:
1397
1398 =over 4
1399
1400 =item table
1401
1402 Table name (required).
1403
1404 =item params
1405
1406 Listref of field names for static fields.  They will be given values from the
1407 PARAMS hashref and passed as a "params" hashref to batch_import.
1408
1409 =item formats
1410
1411 Formats hashref.  Keys are field names, values are listrefs that define the
1412 format.
1413
1414 Each listref value can be a column name or a code reference.  Coderefs are run
1415 with the row object, data and a FS::Conf object as the three parameters.
1416 For example, this coderef does the same thing as using the "columnname" string:
1417
1418   sub {
1419     my( $record, $data, $conf ) = @_;
1420     $record->columnname( $data );
1421   },
1422
1423 Coderefs are run after all "column name" fields are assigned.
1424
1425 =item format_types
1426
1427 Optional format hashref of types.  Keys are field names, values are "csv",
1428 "xls" or "fixedlength".  Overrides automatic determination of file type
1429 from extension.
1430
1431 =item format_headers
1432
1433 Optional format hashref of header lines.  Keys are field names, values are 0
1434 for no header, 1 to ignore the first line, or to higher numbers to ignore that
1435 number of lines.
1436
1437 =item format_sep_chars
1438
1439 Optional format hashref of CSV sep_chars.  Keys are field names, values are the
1440 CSV separation character.
1441
1442 =item format_fixedlenth_formats
1443
1444 Optional format hashref of fixed length format defintiions.  Keys are field
1445 names, values Parse::FixedLength listrefs of field definitions.
1446
1447 =item default_csv
1448
1449 Set true to default to CSV file type if the filename does not contain a
1450 recognizable ".csv" or ".xls" extension (and type is not pre-specified by
1451 format_types).
1452
1453 =back
1454
1455 PARAMS is a base64-encoded Storable string containing the POSTed data as
1456 a hash ref.  It normally contains at least one field, "uploaded files",
1457 generated by /elements/file-upload.html and containing the list of uploaded
1458 files.  Currently only supports a single file named "file".
1459
1460 =cut
1461
1462 use Storable qw(thaw);
1463 use Data::Dumper;
1464 use MIME::Base64;
1465 sub process_batch_import {
1466   my($job, $opt) = ( shift, shift );
1467
1468   my $table = $opt->{table};
1469   my @pass_params = @{ $opt->{params} };
1470   my %formats = %{ $opt->{formats} };
1471
1472   my $param = thaw(decode_base64(shift));
1473   warn Dumper($param) if $DEBUG;
1474
1475   my $files = $param->{'uploaded_files'}
1476     or die "No files provided.\n";
1477
1478   my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
1479
1480   my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
1481   my $file = $dir. $files{'file'};
1482
1483   my $error =
1484     FS::Record::batch_import( {
1485       #class-static
1486       table                      => $table,
1487       formats                    => \%formats,
1488       format_types               => $opt->{format_types},
1489       format_headers             => $opt->{format_headers},
1490       format_sep_chars           => $opt->{format_sep_chars},
1491       format_fixedlength_formats => $opt->{format_fixedlength_formats},
1492       #per-import
1493       job                        => $job,
1494       file                       => $file,
1495       #type                       => $type,
1496       format                     => $param->{format},
1497       params                     => { map { $_ => $param->{$_} } @pass_params },
1498       #?
1499       default_csv                => $opt->{default_csv},
1500     } );
1501
1502   unlink $file;
1503
1504   die "$error\n" if $error;
1505 }
1506
1507 =item batch_import PARAM_HASHREF
1508
1509 Class method for batch imports.  Available params:
1510
1511 =over 4
1512
1513 =item table
1514
1515 =item formats
1516
1517 =item format_types
1518
1519 =item format_headers
1520
1521 =item format_sep_chars
1522
1523 =item format_fixedlength_formats
1524
1525 =item params
1526
1527 =item job
1528
1529 FS::queue object, will be updated with progress
1530
1531 =item file
1532
1533 =item type
1534
1535 csv, xls or fixedlength
1536
1537 =item format
1538
1539 =item empty_ok
1540
1541 =back
1542
1543 =cut
1544
1545 sub batch_import {
1546   my $param = shift;
1547
1548   warn "$me batch_import call with params: \n". Dumper($param)
1549     if $DEBUG;
1550
1551   my $table   = $param->{table};
1552   my $formats = $param->{formats};
1553
1554   my $job     = $param->{job};
1555   my $file    = $param->{file};
1556   my $format  = $param->{'format'};
1557   my $params  = $param->{params} || {};
1558
1559   die "unknown format $format" unless exists $formats->{ $format };
1560
1561   my $type = $param->{'format_types'}
1562              ? $param->{'format_types'}{ $format }
1563              : $param->{type} || 'csv';
1564
1565   unless ( $type ) {
1566     if ( $file =~ /\.(\w+)$/i ) {
1567       $type = lc($1);
1568     } else {
1569       #or error out???
1570       warn "can't parse file type from filename $file; defaulting to CSV";
1571       $type = 'csv';
1572     }
1573     $type = 'csv'
1574       if $param->{'default_csv'} && $type ne 'xls';
1575   }
1576
1577   my $header = $param->{'format_headers'}
1578                  ? $param->{'format_headers'}{ $param->{'format'} }
1579                  : 0;
1580
1581   my $sep_char = $param->{'format_sep_chars'}
1582                    ? $param->{'format_sep_chars'}{ $param->{'format'} }
1583                    : ',';
1584
1585   my $fixedlength_format =
1586     $param->{'format_fixedlength_formats'}
1587       ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
1588       : '';
1589
1590   my @fields = @{ $formats->{ $format } };
1591
1592   my $row = 0;
1593   my $count;
1594   my $parser;
1595   my @buffer = ();
1596   if ( $type eq 'csv' || $type eq 'fixedlength' ) {
1597
1598     if ( $type eq 'csv' ) {
1599
1600       my %attr = ();
1601       $attr{sep_char} = $sep_char if $sep_char;
1602       $parser = new Text::CSV_XS \%attr;
1603
1604     } elsif ( $type eq 'fixedlength' ) {
1605
1606       eval "use Parse::FixedLength;";
1607       die $@ if $@;
1608       $parser = new Parse::FixedLength $fixedlength_format;
1609
1610     } else {
1611       die "Unknown file type $type\n";
1612     }
1613
1614     @buffer = split(/\r?\n/, slurp($file) );
1615     splice(@buffer, 0, ($header || 0) );
1616     $count = scalar(@buffer);
1617
1618   } elsif ( $type eq 'xls' ) {
1619
1620     eval "use Spreadsheet::ParseExcel;";
1621     die $@ if $@;
1622
1623     eval "use DateTime::Format::Excel;";
1624     #for now, just let the error be thrown if it is used, since only CDR
1625     # formats bill_west and troop use it, not other excel-parsing things
1626     #die $@ if $@;
1627
1628     my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
1629
1630     $parser = $excel->{Worksheet}[0]; #first sheet
1631
1632     $count = $parser->{MaxRow} || $parser->{MinRow};
1633     $count++;
1634
1635     $row = $header || 0;
1636
1637   } else {
1638     die "Unknown file type $type\n";
1639   }
1640
1641   #my $columns;
1642
1643   local $SIG{HUP} = 'IGNORE';
1644   local $SIG{INT} = 'IGNORE';
1645   local $SIG{QUIT} = 'IGNORE';
1646   local $SIG{TERM} = 'IGNORE';
1647   local $SIG{TSTP} = 'IGNORE';
1648   local $SIG{PIPE} = 'IGNORE';
1649
1650   my $oldAutoCommit = $FS::UID::AutoCommit;
1651   local $FS::UID::AutoCommit = 0;
1652   my $dbh = dbh;
1653
1654   my $line;
1655   my $imported = 0;
1656   my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
1657   while (1) {
1658
1659     my @columns = ();
1660     if ( $type eq 'csv' ) {
1661
1662       last unless scalar(@buffer);
1663       $line = shift(@buffer);
1664
1665       $parser->parse($line) or do {
1666         $dbh->rollback if $oldAutoCommit;
1667         return "can't parse: ". $parser->error_input();
1668       };
1669       @columns = $parser->fields();
1670
1671     } elsif ( $type eq 'fixedlength' ) {
1672
1673       @columns = $parser->parse($line);
1674
1675     } elsif ( $type eq 'xls' ) {
1676
1677       last if $row > ($parser->{MaxRow} || $parser->{MinRow})
1678            || ! $parser->{Cells}[$row];
1679
1680       my @row = @{ $parser->{Cells}[$row] };
1681       @columns = map $_->{Val}, @row;
1682
1683       #my $z = 'A';
1684       #warn $z++. ": $_\n" for @columns;
1685
1686     } else {
1687       die "Unknown file type $type\n";
1688     }
1689
1690     my @later = ();
1691     my %hash = %$params;
1692
1693     foreach my $field ( @fields ) {
1694
1695       my $value = shift @columns;
1696
1697       if ( ref($field) eq 'CODE' ) {
1698         #&{$field}(\%hash, $value);
1699         push @later, $field, $value;
1700       } else {
1701         #??? $hash{$field} = $value if length($value);
1702         $hash{$field} = $value if defined($value) && length($value);
1703       }
1704
1705     }
1706
1707     my $class = "FS::$table";
1708
1709     my $record = $class->new( \%hash );
1710
1711     while ( scalar(@later) ) {
1712       my $sub = shift @later;
1713       my $data = shift @later;
1714       &{$sub}($record, $data, $conf);  # $record->&{$sub}($data, $conf);
1715     }
1716
1717     my $error = $record->insert;
1718
1719     if ( $error ) {
1720       $dbh->rollback if $oldAutoCommit;
1721       return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
1722     }
1723
1724     $row++;
1725     $imported++;
1726
1727     if ( $job && time - $min_sec > $last ) { #progress bar
1728       $job->update_statustext( int(100 * $imported / $count) );
1729       $last = time;
1730     }
1731
1732   }
1733
1734   $dbh->commit or die $dbh->errstr if $oldAutoCommit;;
1735
1736   return "Empty file!" unless $imported || $param->{empty_ok};
1737
1738   ''; #no error
1739
1740 }
1741
1742 sub _h_statement {
1743   my( $self, $action, $time ) = @_;
1744
1745   $time ||= time;
1746
1747   my @fields =
1748     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1749     real_fields($self->table);
1750   ;
1751
1752   # If we're encrypting then don't ever store the payinfo or CVV2 in the history....
1753   # You can see if it changed by the paymask...
1754   if ($conf && $conf->exists('encryption') ) {
1755     @fields = grep  $_ ne 'payinfo' && $_ ne 'cvv2', @fields;
1756   }
1757   my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
1758
1759   "INSERT INTO h_". $self->table. " ( ".
1760       join(', ', qw(history_date history_user history_action), @fields ).
1761     ") VALUES (".
1762       join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values).
1763     ")"
1764   ;
1765 }
1766
1767 =item unique COLUMN
1768
1769 B<Warning>: External use is B<deprecated>.
1770
1771 Replaces COLUMN in record with a unique number, using counters in the
1772 filesystem.  Used by the B<insert> method on single-field unique columns
1773 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
1774 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
1775
1776 Returns the new value.
1777
1778 =cut
1779
1780 sub unique {
1781   my($self,$field) = @_;
1782   my($table)=$self->table;
1783
1784   croak "Unique called on field $field, but it is ",
1785         $self->getfield($field),
1786         ", not null!"
1787     if $self->getfield($field);
1788
1789   #warn "table $table is tainted" if is_tainted($table);
1790   #warn "field $field is tainted" if is_tainted($field);
1791
1792   my($counter) = new File::CounterFile "$table.$field",0;
1793 # hack for web demo
1794 #  getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!";
1795 #  my($user)=$1;
1796 #  my($counter) = new File::CounterFile "$user/$table.$field",0;
1797 # endhack
1798
1799   my $index = $counter->inc;
1800   $index = $counter->inc while qsearchs($table, { $field=>$index } );
1801
1802   $index =~ /^(\d*)$/;
1803   $index=$1;
1804
1805   $self->setfield($field,$index);
1806
1807 }
1808
1809 =item ut_float COLUMN
1810
1811 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May not be
1812 null.  If there is an error, returns the error, otherwise returns false.
1813
1814 =cut
1815
1816 sub ut_float {
1817   my($self,$field)=@_ ;
1818   ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
1819    $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
1820    $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
1821    $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
1822     or return "Illegal or empty (float) $field: ". $self->getfield($field);
1823   $self->setfield($field,$1);
1824   '';
1825 }
1826 =item ut_floatn COLUMN
1827
1828 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
1829 null.  If there is an error, returns the error, otherwise returns false.
1830
1831 =cut
1832
1833 #false laziness w/ut_ipn
1834 sub ut_floatn {
1835   my( $self, $field ) = @_;
1836   if ( $self->getfield($field) =~ /^()$/ ) {
1837     $self->setfield($field,'');
1838     '';
1839   } else {
1840     $self->ut_float($field);
1841   }
1842 }
1843
1844 =item ut_sfloat COLUMN
1845
1846 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
1847 May not be null.  If there is an error, returns the error, otherwise returns
1848 false.
1849
1850 =cut
1851
1852 sub ut_sfloat {
1853   my($self,$field)=@_ ;
1854   ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
1855    $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
1856    $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
1857    $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
1858     or return "Illegal or empty (float) $field: ". $self->getfield($field);
1859   $self->setfield($field,$1);
1860   '';
1861 }
1862 =item ut_sfloatn COLUMN
1863
1864 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
1865 null.  If there is an error, returns the error, otherwise returns false.
1866
1867 =cut
1868
1869 sub ut_sfloatn {
1870   my( $self, $field ) = @_;
1871   if ( $self->getfield($field) =~ /^()$/ ) {
1872     $self->setfield($field,'');
1873     '';
1874   } else {
1875     $self->ut_sfloat($field);
1876   }
1877 }
1878
1879 =item ut_snumber COLUMN
1880
1881 Check/untaint signed numeric data (whole numbers).  If there is an error,
1882 returns the error, otherwise returns false.
1883
1884 =cut
1885
1886 sub ut_snumber {
1887   my($self, $field) = @_;
1888   $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
1889     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1890   $self->setfield($field, "$1$2");
1891   '';
1892 }
1893
1894 =item ut_snumbern COLUMN
1895
1896 Check/untaint signed numeric data (whole numbers).  If there is an error,
1897 returns the error, otherwise returns false.
1898
1899 =cut
1900
1901 sub ut_snumbern {
1902   my($self, $field) = @_;
1903   $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
1904     or return "Illegal (numeric) $field: ". $self->getfield($field);
1905   if ($1) {
1906     return "Illegal (numeric) $field: ". $self->getfield($field)
1907       unless $2;
1908   }
1909   $self->setfield($field, "$1$2");
1910   '';
1911 }
1912
1913 =item ut_number COLUMN
1914
1915 Check/untaint simple numeric data (whole numbers).  May not be null.  If there
1916 is an error, returns the error, otherwise returns false.
1917
1918 =cut
1919
1920 sub ut_number {
1921   my($self,$field)=@_;
1922   $self->getfield($field) =~ /^\s*(\d+)\s*$/
1923     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1924   $self->setfield($field,$1);
1925   '';
1926 }
1927
1928 =item ut_numbern COLUMN
1929
1930 Check/untaint simple numeric data (whole numbers).  May be null.  If there is
1931 an error, returns the error, otherwise returns false.
1932
1933 =cut
1934
1935 sub ut_numbern {
1936   my($self,$field)=@_;
1937   $self->getfield($field) =~ /^\s*(\d*)\s*$/
1938     or return "Illegal (numeric) $field: ". $self->getfield($field);
1939   $self->setfield($field,$1);
1940   '';
1941 }
1942
1943 =item ut_money COLUMN
1944
1945 Check/untaint monetary numbers.  May be negative.  Set to 0 if null.  If there
1946 is an error, returns the error, otherwise returns false.
1947
1948 =cut
1949
1950 sub ut_money {
1951   my($self,$field)=@_;
1952   $self->setfield($field, 0) if $self->getfield($field) eq '';
1953   $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/
1954     or return "Illegal (money) $field: ". $self->getfield($field);
1955   #$self->setfield($field, "$1$2$3" || 0);
1956   $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
1957   '';
1958 }
1959
1960 =item ut_text COLUMN
1961
1962 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
1963 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
1964 May not be null.  If there is an error, returns the error, otherwise returns
1965 false.
1966
1967 =cut
1968
1969 sub ut_text {
1970   my($self,$field)=@_;
1971   #warn "msgcat ". \&msgcat. "\n";
1972   #warn "notexist ". \&notexist. "\n";
1973   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
1974   $self->getfield($field)
1975     =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>]+)$/
1976       or return gettext('illegal_or_empty_text'). " $field: ".
1977                  $self->getfield($field);
1978   $self->setfield($field,$1);
1979   '';
1980 }
1981
1982 =item ut_textn COLUMN
1983
1984 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
1985 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? /
1986 May be null.  If there is an error, returns the error, otherwise returns false.
1987
1988 =cut
1989
1990 sub ut_textn {
1991   my($self,$field)=@_;
1992   $self->getfield($field)
1993     =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]*)$/
1994       or return gettext('illegal_text'). " $field: ". $self->getfield($field);
1995   $self->setfield($field,$1);
1996   '';
1997 }
1998
1999 =item ut_alpha COLUMN
2000
2001 Check/untaint alphanumeric strings (no spaces).  May not be null.  If there is
2002 an error, returns the error, otherwise returns false.
2003
2004 =cut
2005
2006 sub ut_alpha {
2007   my($self,$field)=@_;
2008   $self->getfield($field) =~ /^(\w+)$/
2009     or return "Illegal or empty (alphanumeric) $field: ".
2010               $self->getfield($field);
2011   $self->setfield($field,$1);
2012   '';
2013 }
2014
2015 =item ut_alpha COLUMN
2016
2017 Check/untaint alphanumeric strings (no spaces).  May be null.  If there is an
2018 error, returns the error, otherwise returns false.
2019
2020 =cut
2021
2022 sub ut_alphan {
2023   my($self,$field)=@_;
2024   $self->getfield($field) =~ /^(\w*)$/
2025     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2026   $self->setfield($field,$1);
2027   '';
2028 }
2029
2030 =item ut_alpha_lower COLUMN
2031
2032 Check/untaint lowercase alphanumeric strings (no spaces).  May not be null.  If
2033 there is an error, returns the error, otherwise returns false.
2034
2035 =cut
2036
2037 sub ut_alpha_lower {
2038   my($self,$field)=@_;
2039   $self->getfield($field) =~ /[[:upper:]]/
2040     and return "Uppercase characters are not permitted in $field";
2041   $self->ut_alpha($field);
2042 }
2043
2044 =item ut_phonen COLUMN [ COUNTRY ]
2045
2046 Check/untaint phone numbers.  May be null.  If there is an error, returns
2047 the error, otherwise returns false.
2048
2049 Takes an optional two-letter ISO country code; without it or with unsupported
2050 countries, ut_phonen simply calls ut_alphan.
2051
2052 =cut
2053
2054 sub ut_phonen {
2055   my( $self, $field, $country ) = @_;
2056   return $self->ut_alphan($field) unless defined $country;
2057   my $phonen = $self->getfield($field);
2058   if ( $phonen eq '' ) {
2059     $self->setfield($field,'');
2060   } elsif ( $country eq 'US' || $country eq 'CA' ) {
2061     $phonen =~ s/\D//g;
2062     $phonen = $conf->config('cust_main-default_areacode').$phonen
2063       if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2064     $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2065       or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2066     $phonen = "$1-$2-$3";
2067     $phonen .= " x$4" if $4;
2068     $self->setfield($field,$phonen);
2069   } else {
2070     warn "warning: don't know how to check phone numbers for country $country";
2071     return $self->ut_textn($field);
2072   }
2073   '';
2074 }
2075
2076 =item ut_hex COLUMN
2077
2078 Check/untaint hexadecimal values.
2079
2080 =cut
2081
2082 sub ut_hex {
2083   my($self, $field) = @_;
2084   $self->getfield($field) =~ /^([\da-fA-F]+)$/
2085     or return "Illegal (hex) $field: ". $self->getfield($field);
2086   $self->setfield($field, uc($1));
2087   '';
2088 }
2089
2090 =item ut_hexn COLUMN
2091
2092 Check/untaint hexadecimal values.  May be null.
2093
2094 =cut
2095
2096 sub ut_hexn {
2097   my($self, $field) = @_;
2098   $self->getfield($field) =~ /^([\da-fA-F]*)$/
2099     or return "Illegal (hex) $field: ". $self->getfield($field);
2100   $self->setfield($field, uc($1));
2101   '';
2102 }
2103 =item ut_ip COLUMN
2104
2105 Check/untaint ip addresses.  IPv4 only for now.
2106
2107 =cut
2108
2109 sub ut_ip {
2110   my( $self, $field ) = @_;
2111   $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2112     or return "Illegal (IP address) $field: ". $self->getfield($field);
2113   for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2114   $self->setfield($field, "$1.$2.$3.$4");
2115   '';
2116 }
2117
2118 =item ut_ipn COLUMN
2119
2120 Check/untaint ip addresses.  IPv4 only for now.  May be null.
2121
2122 =cut
2123
2124 sub ut_ipn {
2125   my( $self, $field ) = @_;
2126   if ( $self->getfield($field) =~ /^()$/ ) {
2127     $self->setfield($field,'');
2128     '';
2129   } else {
2130     $self->ut_ip($field);
2131   }
2132 }
2133
2134 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2135
2136 Check/untaint coordinates.
2137 Accepts the following forms:
2138 DDD.DDDDD
2139 -DDD.DDDDD
2140 DDD MM.MMM
2141 -DDD MM.MMM
2142 DDD MM SS
2143 -DDD MM SS
2144 DDD MM MMM
2145 -DDD MM MMM
2146
2147 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2148 The latter form (that is, the MMM are thousands of minutes) is
2149 assumed if the "MMM" is exactly three digits or two digits > 59.
2150
2151 To be safe, just use the DDD.DDDDD form.
2152
2153 If LOWER or UPPER are specified, then the coordinate is checked
2154 for lower and upper bounds, respectively.
2155
2156 =cut
2157
2158 sub ut_coord {
2159
2160   my ($self, $field) = (shift, shift);
2161
2162   my $lower = shift if scalar(@_);
2163   my $upper = shift if scalar(@_);
2164   my $coord = $self->getfield($field);
2165   my $neg = $coord =~ s/^(-)//;
2166
2167   my ($d, $m, $s) = (0, 0, 0);
2168
2169   if (
2170     (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2171     (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2172     (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2173   ) {
2174     $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2175     $m = $m / 60;
2176     if ($m > 59) {
2177       return "Invalid (coordinate with minutes > 59) $field: "
2178              . $self->getfield($field);
2179     }
2180
2181     $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2182
2183     if (defined($lower) and ($coord < $lower)) {
2184       return "Invalid (coordinate < $lower) $field: "
2185              . $self->getfield($field);;
2186     }
2187
2188     if (defined($upper) and ($coord > $upper)) {
2189       return "Invalid (coordinate > $upper) $field: "
2190              . $self->getfield($field);;
2191     }
2192
2193     $self->setfield($field, $coord);
2194     return '';
2195   }
2196
2197   return "Invalid (coordinate) $field: " . $self->getfield($field);
2198
2199 }
2200
2201 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2202
2203 Same as ut_coord, except optionally null.
2204
2205 =cut
2206
2207 sub ut_coordn {
2208
2209   my ($self, $field) = (shift, shift);
2210
2211   if ($self->getfield($field) =~ /^$/) {
2212     return '';
2213   } else {
2214     return $self->ut_coord($field, @_);
2215   }
2216
2217 }
2218
2219
2220 =item ut_domain COLUMN
2221
2222 Check/untaint host and domain names.
2223
2224 =cut
2225
2226 sub ut_domain {
2227   my( $self, $field ) = @_;
2228   #$self->getfield($field) =~/^(\w+\.)*\w+$/
2229   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2230     or return "Illegal (domain) $field: ". $self->getfield($field);
2231   $self->setfield($field,$1);
2232   '';
2233 }
2234
2235 =item ut_name COLUMN
2236
2237 Check/untaint proper names; allows alphanumerics, spaces and the following
2238 punctuation: , . - '
2239
2240 May not be null.
2241
2242 =cut
2243
2244 sub ut_name {
2245   my( $self, $field ) = @_;
2246   $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
2247     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
2248   $self->setfield($field,$1);
2249   '';
2250 }
2251
2252 =item ut_zip COLUMN
2253
2254 Check/untaint zip codes.
2255
2256 =cut
2257
2258 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2259
2260 sub ut_zip {
2261   my( $self, $field, $country ) = @_;
2262
2263   if ( $country eq 'US' ) {
2264
2265     $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2266       or return gettext('illegal_zip'). " $field for country $country: ".
2267                 $self->getfield($field);
2268     $self->setfield($field, $1);
2269
2270   } elsif ( $country eq 'CA' ) {
2271
2272     $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2273       or return gettext('illegal_zip'). " $field for country $country: ".
2274                 $self->getfield($field);
2275     $self->setfield($field, "$1 $2");
2276
2277   } else {
2278
2279     if ( $self->getfield($field) =~ /^\s*$/
2280          && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
2281        )
2282     {
2283       $self->setfield($field,'');
2284     } else {
2285       $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
2286         or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
2287       $self->setfield($field,$1);
2288     }
2289
2290   }
2291
2292   '';
2293 }
2294
2295 =item ut_country COLUMN
2296
2297 Check/untaint country codes.  Country names are changed to codes, if possible -
2298 see L<Locale::Country>.
2299
2300 =cut
2301
2302 sub ut_country {
2303   my( $self, $field ) = @_;
2304   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
2305     if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
2306          && country2code($1) ) {
2307       $self->setfield($field,uc(country2code($1)));
2308     }
2309   }
2310   $self->getfield($field) =~ /^(\w\w)$/
2311     or return "Illegal (country) $field: ". $self->getfield($field);
2312   $self->setfield($field,uc($1));
2313   '';
2314 }
2315
2316 =item ut_anything COLUMN
2317
2318 Untaints arbitrary data.  Be careful.
2319
2320 =cut
2321
2322 sub ut_anything {
2323   my( $self, $field ) = @_;
2324   $self->getfield($field) =~ /^(.*)$/s
2325     or return "Illegal $field: ". $self->getfield($field);
2326   $self->setfield($field,$1);
2327   '';
2328 }
2329
2330 =item ut_enum COLUMN CHOICES_ARRAYREF
2331
2332 Check/untaint a column, supplying all possible choices, like the "enum" type.
2333
2334 =cut
2335
2336 sub ut_enum {
2337   my( $self, $field, $choices ) = @_;
2338   foreach my $choice ( @$choices ) {
2339     if ( $self->getfield($field) eq $choice ) {
2340       $self->setfield($choice);
2341       return '';
2342     }
2343   }
2344   return "Illegal (enum) field $field: ". $self->getfield($field);
2345 }
2346
2347 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2348
2349 Check/untaint a foreign column key.  Call a regular ut_ method (like ut_number)
2350 on the column first.
2351
2352 =cut
2353
2354 sub ut_foreign_key {
2355   my( $self, $field, $table, $foreign ) = @_;
2356   return '' if $no_check_foreign;
2357   qsearchs($table, { $foreign => $self->getfield($field) })
2358     or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
2359               " in $table.$foreign";
2360   '';
2361 }
2362
2363 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2364
2365 Like ut_foreign_key, except the null value is also allowed.
2366
2367 =cut
2368
2369 sub ut_foreign_keyn {
2370   my( $self, $field, $table, $foreign ) = @_;
2371   $self->getfield($field)
2372     ? $self->ut_foreign_key($field, $table, $foreign)
2373     : '';
2374 }
2375
2376 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
2377
2378 Checks this column as an agentnum, taking into account the current users's
2379 ACLs.  NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
2380 right or rights allowing no agentnum.
2381
2382 =cut
2383
2384 sub ut_agentnum_acl {
2385   my( $self, $field ) = (shift, shift);
2386   my $null_acl = scalar(@_) ? shift : [];
2387   $null_acl = [ $null_acl ] unless ref($null_acl);
2388
2389   my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
2390   return "Illegal agentnum: $error" if $error;
2391
2392   my $curuser = $FS::CurrentUser::CurrentUser;
2393
2394   if ( $self->$field() ) {
2395
2396     return "Access denied"
2397       unless $curuser->agentnum($self->$field());
2398
2399   } else {
2400
2401     return "Access denied"
2402       unless grep $curuser->access_right($_), @$null_acl;
2403
2404   }
2405
2406   '';
2407
2408 }
2409
2410 =item virtual_fields [ TABLE ]
2411
2412 Returns a list of virtual fields defined for the table.  This should not
2413 be exported, and should only be called as an instance or class method.
2414
2415 =cut
2416
2417 sub virtual_fields {
2418   my $self = shift;
2419   my $table;
2420   $table = $self->table or confess "virtual_fields called on non-table";
2421
2422   confess "Unknown table $table" unless dbdef->table($table);
2423
2424   return () unless dbdef->table('part_virtual_field');
2425
2426   unless ( $virtual_fields_cache{$table} ) {
2427     my $query = 'SELECT name from part_virtual_field ' .
2428                 "WHERE dbtable = '$table'";
2429     my $dbh = dbh;
2430     my $result = $dbh->selectcol_arrayref($query);
2431     confess "Error executing virtual fields query: $query: ". $dbh->errstr
2432       if $dbh->err;
2433     $virtual_fields_cache{$table} = $result;
2434   }
2435
2436   @{$virtual_fields_cache{$table}};
2437
2438 }
2439
2440
2441 =item fields [ TABLE ]
2442
2443 This is a wrapper for real_fields and virtual_fields.  Code that called
2444 fields before should probably continue to call fields.
2445
2446 =cut
2447
2448 sub fields {
2449   my $something = shift;
2450   my $table;
2451   if($something->isa('FS::Record')) {
2452     $table = $something->table;
2453   } else {
2454     $table = $something;
2455     $something = "FS::$table";
2456   }
2457   return (real_fields($table), $something->virtual_fields());
2458 }
2459
2460 =item pvf FIELD_NAME
2461
2462 Returns the FS::part_virtual_field object corresponding to a field in the
2463 record (specified by FIELD_NAME).
2464
2465 =cut
2466
2467 sub pvf {
2468   my ($self, $name) = (shift, shift);
2469
2470   if(grep /^$name$/, $self->virtual_fields) {
2471     return qsearchs('part_virtual_field', { dbtable => $self->table,
2472                                             name    => $name } );
2473   }
2474   ''
2475 }
2476
2477 =item vfieldpart_hashref TABLE
2478
2479 Returns a hashref of virtual field names and vfieldparts applicable to the given
2480 TABLE.
2481
2482 =cut
2483
2484 sub vfieldpart_hashref {
2485   my $self = shift;
2486   my $table = $self->table;
2487
2488   return {} unless dbdef->table('part_virtual_field');
2489
2490   my $dbh = dbh;
2491   my $statement = "SELECT vfieldpart, name FROM part_virtual_field WHERE ".
2492                   "dbtable = '$table'";
2493   my $sth = $dbh->prepare($statement);
2494   $sth->execute or croak "Execution of '$statement' failed: ".$dbh->errstr;
2495   return { map { $_->{name}, $_->{vfieldpart} }
2496     @{$sth->fetchall_arrayref({})} };
2497
2498 }
2499
2500 =item encrypt($value)
2501
2502 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
2503
2504 Returns the encrypted string.
2505
2506 You should generally not have to worry about calling this, as the system handles this for you.
2507
2508 =cut
2509
2510 sub encrypt {
2511   my ($self, $value) = @_;
2512   my $encrypted;
2513
2514   if ($conf->exists('encryption')) {
2515     if ($self->is_encrypted($value)) {
2516       # Return the original value if it isn't plaintext.
2517       $encrypted = $value;
2518     } else {
2519       $self->loadRSA;
2520       if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
2521         # RSA doesn't like the empty string so let's pack it up
2522         # The database doesn't like the RSA data so uuencode it
2523         my $length = length($value)+1;
2524         $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
2525       } else {
2526         die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
2527       }
2528     }
2529   }
2530   return $encrypted;
2531 }
2532
2533 =item is_encrypted($value)
2534
2535 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
2536
2537 =cut
2538
2539
2540 sub is_encrypted {
2541   my ($self, $value) = @_;
2542   # Possible Bug - Some work may be required here....
2543
2544   if ($value =~ /^M/ && length($value) > 80) {
2545     return 1;
2546   } else {
2547     return 0;
2548   }
2549 }
2550
2551 =item decrypt($value)
2552
2553 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
2554
2555 You should generally not have to worry about calling this, as the system handles this for you.
2556
2557 =cut
2558
2559 sub decrypt {
2560   my ($self,$value) = @_;
2561   my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
2562   if ($conf->exists('encryption') && $self->is_encrypted($value)) {
2563     $self->loadRSA;
2564     if (ref($rsa_decrypt) =~ /::RSA/) {
2565       my $encrypted = unpack ("u*", $value);
2566       $decrypted =  unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
2567       if ($@) {warn "Decryption Failed"};
2568     }
2569   }
2570   return $decrypted;
2571 }
2572
2573 sub loadRSA {
2574     my $self = shift;
2575     #Initialize the Module
2576     $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
2577
2578     if ($conf->exists('encryptionmodule') && $conf->config_binary('encryptionmodule') ne '') {
2579       $rsa_module = $conf->config('encryptionmodule');
2580     }
2581
2582     if (!$rsa_loaded) {
2583         eval ("require $rsa_module"); # No need to import the namespace
2584         $rsa_loaded++;
2585     }
2586     # Initialize Encryption
2587     if ($conf->exists('encryptionpublickey') && $conf->config_binary('encryptionpublickey') ne '') {
2588       my $public_key = join("\n",$conf->config('encryptionpublickey'));
2589       $rsa_encrypt = $rsa_module->new_public_key($public_key);
2590     }
2591
2592     # Intitalize Decryption
2593     if ($conf->exists('encryptionprivatekey') && $conf->config_binary('encryptionprivatekey') ne '') {
2594       my $private_key = join("\n",$conf->config('encryptionprivatekey'));
2595       $rsa_decrypt = $rsa_module->new_private_key($private_key);
2596     }
2597 }
2598
2599 =item h_search ACTION
2600
2601 Given an ACTION, either "insert", or "delete", returns the appropriate history
2602 record corresponding to this record, if any.
2603
2604 =cut
2605
2606 sub h_search {
2607   my( $self, $action ) = @_;
2608
2609   my $table = $self->table;
2610   $table =~ s/^h_//;
2611
2612   my $primary_key = dbdef->table($table)->primary_key;
2613
2614   qsearchs({
2615     'table'   => "h_$table",
2616     'hashref' => { $primary_key     => $self->$primary_key(),
2617                    'history_action' => $action,
2618                  },
2619   });
2620
2621 }
2622
2623 =item h_date ACTION
2624
2625 Given an ACTION, either "insert", or "delete", returns the timestamp of the
2626 appropriate history record corresponding to this record, if any.
2627
2628 =cut
2629
2630 sub h_date {
2631   my($self, $action) = @_;
2632   my $h = $self->h_search($action);
2633   $h ? $h->history_date : '';
2634 }
2635
2636 =back
2637
2638 =head1 SUBROUTINES
2639
2640 =over 4
2641
2642 =item real_fields [ TABLE ]
2643
2644 Returns a list of the real columns in the specified table.  Called only by
2645 fields() and other subroutines elsewhere in FS::Record.
2646
2647 =cut
2648
2649 sub real_fields {
2650   my $table = shift;
2651
2652   my($table_obj) = dbdef->table($table);
2653   confess "Unknown table $table" unless $table_obj;
2654   $table_obj->columns;
2655 }
2656
2657 =item _quote VALUE, TABLE, COLUMN
2658
2659 This is an internal function used to construct SQL statements.  It returns
2660 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
2661 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
2662
2663 =cut
2664
2665 sub _quote {
2666   my($value, $table, $column) = @_;
2667   my $column_obj = dbdef->table($table)->column($column);
2668   my $column_type = $column_obj->type;
2669   my $nullable = $column_obj->null;
2670
2671   warn "  $table.$column: $value ($column_type".
2672        ( $nullable ? ' NULL' : ' NOT NULL' ).
2673        ")\n" if $DEBUG > 2;
2674
2675   if ( $value eq '' && $nullable ) {
2676     'NULL'
2677   } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
2678     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
2679           "using 0 instead";
2680     0;
2681   } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
2682             ! $column_type =~ /(char|binary|text)$/i ) {
2683     $value;
2684   } else {
2685     dbh->quote($value);
2686   }
2687 }
2688
2689 =item hfields TABLE
2690
2691 This is deprecated.  Don't use it.
2692
2693 It returns a hash-type list with the fields of this record's table set true.
2694
2695 =cut
2696
2697 sub hfields {
2698   carp "warning: hfields is deprecated";
2699   my($table)=@_;
2700   my(%hash);
2701   foreach (fields($table)) {
2702     $hash{$_}=1;
2703   }
2704   \%hash;
2705 }
2706
2707 sub _dump {
2708   my($self)=@_;
2709   join("\n", map {
2710     "$_: ". $self->getfield($_). "|"
2711   } (fields($self->table)) );
2712 }
2713
2714 sub DESTROY { return; }
2715
2716 #sub DESTROY {
2717 #  my $self = shift;
2718 #  #use Carp qw(cluck);
2719 #  #cluck "DESTROYING $self";
2720 #  warn "DESTROYING $self";
2721 #}
2722
2723 #sub is_tainted {
2724 #             return ! eval { join('',@_), kill 0; 1; };
2725 #         }
2726
2727 =item str2time_sql [ DRIVER_NAME ]
2728
2729 Returns a function to convert to unix time based on database type, such as
2730 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql.  See
2731 the str2time_sql_closing method to return a closing string rather than just
2732 using a closing parenthesis as previously suggested.
2733
2734 You can pass an optional driver name such as "Pg", "mysql" or
2735 $dbh->{Driver}->{Name} to return a function for that database instead of
2736 the current database.
2737
2738 =cut
2739
2740 sub str2time_sql {
2741   my $driver = shift || driver_name;
2742
2743   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;
2744   return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
2745
2746   warn "warning: unknown database type $driver; guessing how to convert ".
2747        "dates to UNIX timestamps";
2748   return 'EXTRACT(EPOCH FROM ';
2749
2750 }
2751
2752 =item str2time_sql_closing [ DRIVER_NAME ]
2753
2754 Returns the closing suffix of a function to convert to unix time based on
2755 database type, such as ")::integer" for Pg or ")" for mysql.
2756
2757 You can pass an optional driver name such as "Pg", "mysql" or
2758 $dbh->{Driver}->{Name} to return a function for that database instead of
2759 the current database.
2760
2761 =cut
2762
2763 sub str2time_sql_closing {
2764   my $driver = shift || driver_name;
2765
2766   return ' )::INTEGER ' if $driver =~ /^Pg/i;
2767   return ' ) ';
2768 }
2769
2770 =back
2771
2772 =head1 BUGS
2773
2774 This module should probably be renamed, since much of the functionality is
2775 of general use.  It is not completely unlike Adapter::DBI (see below).
2776
2777 Exported qsearch and qsearchs should be deprecated in favor of method calls
2778 (against an FS::Record object like the old search and searchs that qsearch
2779 and qsearchs were on top of.)
2780
2781 The whole fields / hfields mess should be removed.
2782
2783 The various WHERE clauses should be subroutined.
2784
2785 table string should be deprecated in favor of DBIx::DBSchema::Table.
2786
2787 No doubt we could benefit from a Tied hash.  Documenting how exists / defined
2788 true maps to the database (and WHERE clauses) would also help.
2789
2790 The ut_ methods should ask the dbdef for a default length.
2791
2792 ut_sqltype (like ut_varchar) should all be defined
2793
2794 A fallback check method should be provided which uses the dbdef.
2795
2796 The ut_money method assumes money has two decimal digits.
2797
2798 The Pg money kludge in the new method only strips `$'.
2799
2800 The ut_phonen method only checks US-style phone numbers.
2801
2802 The _quote function should probably use ut_float instead of a regex.
2803
2804 All the subroutines probably should be methods, here or elsewhere.
2805
2806 Probably should borrow/use some dbdef methods where appropriate (like sub
2807 fields)
2808
2809 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
2810 or allow it to be set.  Working around it is ugly any way around - DBI should
2811 be fixed.  (only affects RDBMS which return uppercase column names)
2812
2813 ut_zip should take an optional country like ut_phone.
2814
2815 =head1 SEE ALSO
2816
2817 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
2818
2819 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
2820
2821 http://poop.sf.net/
2822
2823 =cut
2824
2825 1;
2826