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     my $param = {};
1712     while ( scalar(@later) ) {
1713       my $sub = shift @later;
1714       my $data = shift @later;
1715       &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf);
1716       last if exists( $param->{skiprow} );
1717     }
1718     next if exists( $param->{skiprow} );
1719
1720     my $error = $record->insert;
1721
1722     if ( $error ) {
1723       $dbh->rollback if $oldAutoCommit;
1724       return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
1725     }
1726
1727     $row++;
1728     $imported++;
1729
1730     if ( $job && time - $min_sec > $last ) { #progress bar
1731       $job->update_statustext( int(100 * $imported / $count) );
1732       $last = time;
1733     }
1734
1735   }
1736
1737   $dbh->commit or die $dbh->errstr if $oldAutoCommit;;
1738
1739   return "Empty file!" unless $imported || $param->{empty_ok};
1740
1741   ''; #no error
1742
1743 }
1744
1745 sub _h_statement {
1746   my( $self, $action, $time ) = @_;
1747
1748   $time ||= time;
1749
1750   my @fields =
1751     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1752     real_fields($self->table);
1753   ;
1754
1755   # If we're encrypting then don't ever store the payinfo or CVV2 in the history....
1756   # You can see if it changed by the paymask...
1757   if ($conf && $conf->exists('encryption') ) {
1758     @fields = grep  $_ ne 'payinfo' && $_ ne 'cvv2', @fields;
1759   }
1760   my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
1761
1762   "INSERT INTO h_". $self->table. " ( ".
1763       join(', ', qw(history_date history_user history_action), @fields ).
1764     ") VALUES (".
1765       join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values).
1766     ")"
1767   ;
1768 }
1769
1770 =item unique COLUMN
1771
1772 B<Warning>: External use is B<deprecated>.
1773
1774 Replaces COLUMN in record with a unique number, using counters in the
1775 filesystem.  Used by the B<insert> method on single-field unique columns
1776 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
1777 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
1778
1779 Returns the new value.
1780
1781 =cut
1782
1783 sub unique {
1784   my($self,$field) = @_;
1785   my($table)=$self->table;
1786
1787   croak "Unique called on field $field, but it is ",
1788         $self->getfield($field),
1789         ", not null!"
1790     if $self->getfield($field);
1791
1792   #warn "table $table is tainted" if is_tainted($table);
1793   #warn "field $field is tainted" if is_tainted($field);
1794
1795   my($counter) = new File::CounterFile "$table.$field",0;
1796 # hack for web demo
1797 #  getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!";
1798 #  my($user)=$1;
1799 #  my($counter) = new File::CounterFile "$user/$table.$field",0;
1800 # endhack
1801
1802   my $index = $counter->inc;
1803   $index = $counter->inc while qsearchs($table, { $field=>$index } );
1804
1805   $index =~ /^(\d*)$/;
1806   $index=$1;
1807
1808   $self->setfield($field,$index);
1809
1810 }
1811
1812 =item ut_float COLUMN
1813
1814 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May not be
1815 null.  If there is an error, returns the error, otherwise returns false.
1816
1817 =cut
1818
1819 sub ut_float {
1820   my($self,$field)=@_ ;
1821   ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
1822    $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
1823    $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
1824    $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
1825     or return "Illegal or empty (float) $field: ". $self->getfield($field);
1826   $self->setfield($field,$1);
1827   '';
1828 }
1829 =item ut_floatn COLUMN
1830
1831 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
1832 null.  If there is an error, returns the error, otherwise returns false.
1833
1834 =cut
1835
1836 #false laziness w/ut_ipn
1837 sub ut_floatn {
1838   my( $self, $field ) = @_;
1839   if ( $self->getfield($field) =~ /^()$/ ) {
1840     $self->setfield($field,'');
1841     '';
1842   } else {
1843     $self->ut_float($field);
1844   }
1845 }
1846
1847 =item ut_sfloat COLUMN
1848
1849 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
1850 May not be null.  If there is an error, returns the error, otherwise returns
1851 false.
1852
1853 =cut
1854
1855 sub ut_sfloat {
1856   my($self,$field)=@_ ;
1857   ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
1858    $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
1859    $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
1860    $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
1861     or return "Illegal or empty (float) $field: ". $self->getfield($field);
1862   $self->setfield($field,$1);
1863   '';
1864 }
1865 =item ut_sfloatn COLUMN
1866
1867 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
1868 null.  If there is an error, returns the error, otherwise returns false.
1869
1870 =cut
1871
1872 sub ut_sfloatn {
1873   my( $self, $field ) = @_;
1874   if ( $self->getfield($field) =~ /^()$/ ) {
1875     $self->setfield($field,'');
1876     '';
1877   } else {
1878     $self->ut_sfloat($field);
1879   }
1880 }
1881
1882 =item ut_snumber COLUMN
1883
1884 Check/untaint signed numeric data (whole numbers).  If there is an error,
1885 returns the error, otherwise returns false.
1886
1887 =cut
1888
1889 sub ut_snumber {
1890   my($self, $field) = @_;
1891   $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
1892     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1893   $self->setfield($field, "$1$2");
1894   '';
1895 }
1896
1897 =item ut_snumbern COLUMN
1898
1899 Check/untaint signed numeric data (whole numbers).  If there is an error,
1900 returns the error, otherwise returns false.
1901
1902 =cut
1903
1904 sub ut_snumbern {
1905   my($self, $field) = @_;
1906   $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
1907     or return "Illegal (numeric) $field: ". $self->getfield($field);
1908   if ($1) {
1909     return "Illegal (numeric) $field: ". $self->getfield($field)
1910       unless $2;
1911   }
1912   $self->setfield($field, "$1$2");
1913   '';
1914 }
1915
1916 =item ut_number COLUMN
1917
1918 Check/untaint simple numeric data (whole numbers).  May not be null.  If there
1919 is an error, returns the error, otherwise returns false.
1920
1921 =cut
1922
1923 sub ut_number {
1924   my($self,$field)=@_;
1925   $self->getfield($field) =~ /^\s*(\d+)\s*$/
1926     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1927   $self->setfield($field,$1);
1928   '';
1929 }
1930
1931 =item ut_numbern COLUMN
1932
1933 Check/untaint simple numeric data (whole numbers).  May be null.  If there is
1934 an error, returns the error, otherwise returns false.
1935
1936 =cut
1937
1938 sub ut_numbern {
1939   my($self,$field)=@_;
1940   $self->getfield($field) =~ /^\s*(\d*)\s*$/
1941     or return "Illegal (numeric) $field: ". $self->getfield($field);
1942   $self->setfield($field,$1);
1943   '';
1944 }
1945
1946 =item ut_money COLUMN
1947
1948 Check/untaint monetary numbers.  May be negative.  Set to 0 if null.  If there
1949 is an error, returns the error, otherwise returns false.
1950
1951 =cut
1952
1953 sub ut_money {
1954   my($self,$field)=@_;
1955   $self->setfield($field, 0) if $self->getfield($field) eq '';
1956   $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/
1957     or return "Illegal (money) $field: ". $self->getfield($field);
1958   #$self->setfield($field, "$1$2$3" || 0);
1959   $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
1960   '';
1961 }
1962
1963 =item ut_text COLUMN
1964
1965 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
1966 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
1967 May not be null.  If there is an error, returns the error, otherwise returns
1968 false.
1969
1970 =cut
1971
1972 sub ut_text {
1973   my($self,$field)=@_;
1974   #warn "msgcat ". \&msgcat. "\n";
1975   #warn "notexist ". \&notexist. "\n";
1976   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
1977   $self->getfield($field)
1978     =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>]+)$/
1979       or return gettext('illegal_or_empty_text'). " $field: ".
1980                  $self->getfield($field);
1981   $self->setfield($field,$1);
1982   '';
1983 }
1984
1985 =item ut_textn COLUMN
1986
1987 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
1988 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? /
1989 May be null.  If there is an error, returns the error, otherwise returns false.
1990
1991 =cut
1992
1993 sub ut_textn {
1994   my($self,$field)=@_;
1995   $self->getfield($field)
1996     =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]*)$/
1997       or return gettext('illegal_text'). " $field: ". $self->getfield($field);
1998   $self->setfield($field,$1);
1999   '';
2000 }
2001
2002 =item ut_alpha COLUMN
2003
2004 Check/untaint alphanumeric strings (no spaces).  May not be null.  If there is
2005 an error, returns the error, otherwise returns false.
2006
2007 =cut
2008
2009 sub ut_alpha {
2010   my($self,$field)=@_;
2011   $self->getfield($field) =~ /^(\w+)$/
2012     or return "Illegal or empty (alphanumeric) $field: ".
2013               $self->getfield($field);
2014   $self->setfield($field,$1);
2015   '';
2016 }
2017
2018 =item ut_alpha COLUMN
2019
2020 Check/untaint alphanumeric strings (no spaces).  May be null.  If there is an
2021 error, returns the error, otherwise returns false.
2022
2023 =cut
2024
2025 sub ut_alphan {
2026   my($self,$field)=@_;
2027   $self->getfield($field) =~ /^(\w*)$/
2028     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2029   $self->setfield($field,$1);
2030   '';
2031 }
2032
2033 =item ut_alpha_lower COLUMN
2034
2035 Check/untaint lowercase alphanumeric strings (no spaces).  May not be null.  If
2036 there is an error, returns the error, otherwise returns false.
2037
2038 =cut
2039
2040 sub ut_alpha_lower {
2041   my($self,$field)=@_;
2042   $self->getfield($field) =~ /[[:upper:]]/
2043     and return "Uppercase characters are not permitted in $field";
2044   $self->ut_alpha($field);
2045 }
2046
2047 =item ut_phonen COLUMN [ COUNTRY ]
2048
2049 Check/untaint phone numbers.  May be null.  If there is an error, returns
2050 the error, otherwise returns false.
2051
2052 Takes an optional two-letter ISO country code; without it or with unsupported
2053 countries, ut_phonen simply calls ut_alphan.
2054
2055 =cut
2056
2057 sub ut_phonen {
2058   my( $self, $field, $country ) = @_;
2059   return $self->ut_alphan($field) unless defined $country;
2060   my $phonen = $self->getfield($field);
2061   if ( $phonen eq '' ) {
2062     $self->setfield($field,'');
2063   } elsif ( $country eq 'US' || $country eq 'CA' ) {
2064     $phonen =~ s/\D//g;
2065     $phonen = $conf->config('cust_main-default_areacode').$phonen
2066       if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2067     $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2068       or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2069     $phonen = "$1-$2-$3";
2070     $phonen .= " x$4" if $4;
2071     $self->setfield($field,$phonen);
2072   } else {
2073     warn "warning: don't know how to check phone numbers for country $country";
2074     return $self->ut_textn($field);
2075   }
2076   '';
2077 }
2078
2079 =item ut_hex COLUMN
2080
2081 Check/untaint hexadecimal values.
2082
2083 =cut
2084
2085 sub ut_hex {
2086   my($self, $field) = @_;
2087   $self->getfield($field) =~ /^([\da-fA-F]+)$/
2088     or return "Illegal (hex) $field: ". $self->getfield($field);
2089   $self->setfield($field, uc($1));
2090   '';
2091 }
2092
2093 =item ut_hexn COLUMN
2094
2095 Check/untaint hexadecimal values.  May be null.
2096
2097 =cut
2098
2099 sub ut_hexn {
2100   my($self, $field) = @_;
2101   $self->getfield($field) =~ /^([\da-fA-F]*)$/
2102     or return "Illegal (hex) $field: ". $self->getfield($field);
2103   $self->setfield($field, uc($1));
2104   '';
2105 }
2106 =item ut_ip COLUMN
2107
2108 Check/untaint ip addresses.  IPv4 only for now.
2109
2110 =cut
2111
2112 sub ut_ip {
2113   my( $self, $field ) = @_;
2114   $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2115     or return "Illegal (IP address) $field: ". $self->getfield($field);
2116   for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2117   $self->setfield($field, "$1.$2.$3.$4");
2118   '';
2119 }
2120
2121 =item ut_ipn COLUMN
2122
2123 Check/untaint ip addresses.  IPv4 only for now.  May be null.
2124
2125 =cut
2126
2127 sub ut_ipn {
2128   my( $self, $field ) = @_;
2129   if ( $self->getfield($field) =~ /^()$/ ) {
2130     $self->setfield($field,'');
2131     '';
2132   } else {
2133     $self->ut_ip($field);
2134   }
2135 }
2136
2137 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2138
2139 Check/untaint coordinates.
2140 Accepts the following forms:
2141 DDD.DDDDD
2142 -DDD.DDDDD
2143 DDD MM.MMM
2144 -DDD MM.MMM
2145 DDD MM SS
2146 -DDD MM SS
2147 DDD MM MMM
2148 -DDD MM MMM
2149
2150 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2151 The latter form (that is, the MMM are thousands of minutes) is
2152 assumed if the "MMM" is exactly three digits or two digits > 59.
2153
2154 To be safe, just use the DDD.DDDDD form.
2155
2156 If LOWER or UPPER are specified, then the coordinate is checked
2157 for lower and upper bounds, respectively.
2158
2159 =cut
2160
2161 sub ut_coord {
2162
2163   my ($self, $field) = (shift, shift);
2164
2165   my $lower = shift if scalar(@_);
2166   my $upper = shift if scalar(@_);
2167   my $coord = $self->getfield($field);
2168   my $neg = $coord =~ s/^(-)//;
2169
2170   my ($d, $m, $s) = (0, 0, 0);
2171
2172   if (
2173     (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2174     (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2175     (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2176   ) {
2177     $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2178     $m = $m / 60;
2179     if ($m > 59) {
2180       return "Invalid (coordinate with minutes > 59) $field: "
2181              . $self->getfield($field);
2182     }
2183
2184     $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2185
2186     if (defined($lower) and ($coord < $lower)) {
2187       return "Invalid (coordinate < $lower) $field: "
2188              . $self->getfield($field);;
2189     }
2190
2191     if (defined($upper) and ($coord > $upper)) {
2192       return "Invalid (coordinate > $upper) $field: "
2193              . $self->getfield($field);;
2194     }
2195
2196     $self->setfield($field, $coord);
2197     return '';
2198   }
2199
2200   return "Invalid (coordinate) $field: " . $self->getfield($field);
2201
2202 }
2203
2204 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2205
2206 Same as ut_coord, except optionally null.
2207
2208 =cut
2209
2210 sub ut_coordn {
2211
2212   my ($self, $field) = (shift, shift);
2213
2214   if ($self->getfield($field) =~ /^$/) {
2215     return '';
2216   } else {
2217     return $self->ut_coord($field, @_);
2218   }
2219
2220 }
2221
2222
2223 =item ut_domain COLUMN
2224
2225 Check/untaint host and domain names.
2226
2227 =cut
2228
2229 sub ut_domain {
2230   my( $self, $field ) = @_;
2231   #$self->getfield($field) =~/^(\w+\.)*\w+$/
2232   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2233     or return "Illegal (domain) $field: ". $self->getfield($field);
2234   $self->setfield($field,$1);
2235   '';
2236 }
2237
2238 =item ut_name COLUMN
2239
2240 Check/untaint proper names; allows alphanumerics, spaces and the following
2241 punctuation: , . - '
2242
2243 May not be null.
2244
2245 =cut
2246
2247 sub ut_name {
2248   my( $self, $field ) = @_;
2249   $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
2250     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
2251   $self->setfield($field,$1);
2252   '';
2253 }
2254
2255 =item ut_zip COLUMN
2256
2257 Check/untaint zip codes.
2258
2259 =cut
2260
2261 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2262
2263 sub ut_zip {
2264   my( $self, $field, $country ) = @_;
2265
2266   if ( $country eq 'US' ) {
2267
2268     $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2269       or return gettext('illegal_zip'). " $field for country $country: ".
2270                 $self->getfield($field);
2271     $self->setfield($field, $1);
2272
2273   } elsif ( $country eq 'CA' ) {
2274
2275     $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2276       or return gettext('illegal_zip'). " $field for country $country: ".
2277                 $self->getfield($field);
2278     $self->setfield($field, "$1 $2");
2279
2280   } else {
2281
2282     if ( $self->getfield($field) =~ /^\s*$/
2283          && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
2284        )
2285     {
2286       $self->setfield($field,'');
2287     } else {
2288       $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
2289         or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
2290       $self->setfield($field,$1);
2291     }
2292
2293   }
2294
2295   '';
2296 }
2297
2298 =item ut_country COLUMN
2299
2300 Check/untaint country codes.  Country names are changed to codes, if possible -
2301 see L<Locale::Country>.
2302
2303 =cut
2304
2305 sub ut_country {
2306   my( $self, $field ) = @_;
2307   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
2308     if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
2309          && country2code($1) ) {
2310       $self->setfield($field,uc(country2code($1)));
2311     }
2312   }
2313   $self->getfield($field) =~ /^(\w\w)$/
2314     or return "Illegal (country) $field: ". $self->getfield($field);
2315   $self->setfield($field,uc($1));
2316   '';
2317 }
2318
2319 =item ut_anything COLUMN
2320
2321 Untaints arbitrary data.  Be careful.
2322
2323 =cut
2324
2325 sub ut_anything {
2326   my( $self, $field ) = @_;
2327   $self->getfield($field) =~ /^(.*)$/s
2328     or return "Illegal $field: ". $self->getfield($field);
2329   $self->setfield($field,$1);
2330   '';
2331 }
2332
2333 =item ut_enum COLUMN CHOICES_ARRAYREF
2334
2335 Check/untaint a column, supplying all possible choices, like the "enum" type.
2336
2337 =cut
2338
2339 sub ut_enum {
2340   my( $self, $field, $choices ) = @_;
2341   foreach my $choice ( @$choices ) {
2342     if ( $self->getfield($field) eq $choice ) {
2343       $self->setfield($choice);
2344       return '';
2345     }
2346   }
2347   return "Illegal (enum) field $field: ". $self->getfield($field);
2348 }
2349
2350 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2351
2352 Check/untaint a foreign column key.  Call a regular ut_ method (like ut_number)
2353 on the column first.
2354
2355 =cut
2356
2357 sub ut_foreign_key {
2358   my( $self, $field, $table, $foreign ) = @_;
2359   return '' if $no_check_foreign;
2360   qsearchs($table, { $foreign => $self->getfield($field) })
2361     or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
2362               " in $table.$foreign";
2363   '';
2364 }
2365
2366 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2367
2368 Like ut_foreign_key, except the null value is also allowed.
2369
2370 =cut
2371
2372 sub ut_foreign_keyn {
2373   my( $self, $field, $table, $foreign ) = @_;
2374   $self->getfield($field)
2375     ? $self->ut_foreign_key($field, $table, $foreign)
2376     : '';
2377 }
2378
2379 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
2380
2381 Checks this column as an agentnum, taking into account the current users's
2382 ACLs.  NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
2383 right or rights allowing no agentnum.
2384
2385 =cut
2386
2387 sub ut_agentnum_acl {
2388   my( $self, $field ) = (shift, shift);
2389   my $null_acl = scalar(@_) ? shift : [];
2390   $null_acl = [ $null_acl ] unless ref($null_acl);
2391
2392   my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
2393   return "Illegal agentnum: $error" if $error;
2394
2395   my $curuser = $FS::CurrentUser::CurrentUser;
2396
2397   if ( $self->$field() ) {
2398
2399     return "Access denied"
2400       unless $curuser->agentnum($self->$field());
2401
2402   } else {
2403
2404     return "Access denied"
2405       unless grep $curuser->access_right($_), @$null_acl;
2406
2407   }
2408
2409   '';
2410
2411 }
2412
2413 =item virtual_fields [ TABLE ]
2414
2415 Returns a list of virtual fields defined for the table.  This should not
2416 be exported, and should only be called as an instance or class method.
2417
2418 =cut
2419
2420 sub virtual_fields {
2421   my $self = shift;
2422   my $table;
2423   $table = $self->table or confess "virtual_fields called on non-table";
2424
2425   confess "Unknown table $table" unless dbdef->table($table);
2426
2427   return () unless dbdef->table('part_virtual_field');
2428
2429   unless ( $virtual_fields_cache{$table} ) {
2430     my $query = 'SELECT name from part_virtual_field ' .
2431                 "WHERE dbtable = '$table'";
2432     my $dbh = dbh;
2433     my $result = $dbh->selectcol_arrayref($query);
2434     confess "Error executing virtual fields query: $query: ". $dbh->errstr
2435       if $dbh->err;
2436     $virtual_fields_cache{$table} = $result;
2437   }
2438
2439   @{$virtual_fields_cache{$table}};
2440
2441 }
2442
2443
2444 =item fields [ TABLE ]
2445
2446 This is a wrapper for real_fields and virtual_fields.  Code that called
2447 fields before should probably continue to call fields.
2448
2449 =cut
2450
2451 sub fields {
2452   my $something = shift;
2453   my $table;
2454   if($something->isa('FS::Record')) {
2455     $table = $something->table;
2456   } else {
2457     $table = $something;
2458     $something = "FS::$table";
2459   }
2460   return (real_fields($table), $something->virtual_fields());
2461 }
2462
2463 =item pvf FIELD_NAME
2464
2465 Returns the FS::part_virtual_field object corresponding to a field in the
2466 record (specified by FIELD_NAME).
2467
2468 =cut
2469
2470 sub pvf {
2471   my ($self, $name) = (shift, shift);
2472
2473   if(grep /^$name$/, $self->virtual_fields) {
2474     return qsearchs('part_virtual_field', { dbtable => $self->table,
2475                                             name    => $name } );
2476   }
2477   ''
2478 }
2479
2480 =item vfieldpart_hashref TABLE
2481
2482 Returns a hashref of virtual field names and vfieldparts applicable to the given
2483 TABLE.
2484
2485 =cut
2486
2487 sub vfieldpart_hashref {
2488   my $self = shift;
2489   my $table = $self->table;
2490
2491   return {} unless dbdef->table('part_virtual_field');
2492
2493   my $dbh = dbh;
2494   my $statement = "SELECT vfieldpart, name FROM part_virtual_field WHERE ".
2495                   "dbtable = '$table'";
2496   my $sth = $dbh->prepare($statement);
2497   $sth->execute or croak "Execution of '$statement' failed: ".$dbh->errstr;
2498   return { map { $_->{name}, $_->{vfieldpart} }
2499     @{$sth->fetchall_arrayref({})} };
2500
2501 }
2502
2503 =item encrypt($value)
2504
2505 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
2506
2507 Returns the encrypted string.
2508
2509 You should generally not have to worry about calling this, as the system handles this for you.
2510
2511 =cut
2512
2513 sub encrypt {
2514   my ($self, $value) = @_;
2515   my $encrypted;
2516
2517   if ($conf->exists('encryption')) {
2518     if ($self->is_encrypted($value)) {
2519       # Return the original value if it isn't plaintext.
2520       $encrypted = $value;
2521     } else {
2522       $self->loadRSA;
2523       if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
2524         # RSA doesn't like the empty string so let's pack it up
2525         # The database doesn't like the RSA data so uuencode it
2526         my $length = length($value)+1;
2527         $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
2528       } else {
2529         die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
2530       }
2531     }
2532   }
2533   return $encrypted;
2534 }
2535
2536 =item is_encrypted($value)
2537
2538 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
2539
2540 =cut
2541
2542
2543 sub is_encrypted {
2544   my ($self, $value) = @_;
2545   # Possible Bug - Some work may be required here....
2546
2547   if ($value =~ /^M/ && length($value) > 80) {
2548     return 1;
2549   } else {
2550     return 0;
2551   }
2552 }
2553
2554 =item decrypt($value)
2555
2556 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
2557
2558 You should generally not have to worry about calling this, as the system handles this for you.
2559
2560 =cut
2561
2562 sub decrypt {
2563   my ($self,$value) = @_;
2564   my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
2565   if ($conf->exists('encryption') && $self->is_encrypted($value)) {
2566     $self->loadRSA;
2567     if (ref($rsa_decrypt) =~ /::RSA/) {
2568       my $encrypted = unpack ("u*", $value);
2569       $decrypted =  unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
2570       if ($@) {warn "Decryption Failed"};
2571     }
2572   }
2573   return $decrypted;
2574 }
2575
2576 sub loadRSA {
2577     my $self = shift;
2578     #Initialize the Module
2579     $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
2580
2581     if ($conf->exists('encryptionmodule') && $conf->config_binary('encryptionmodule') ne '') {
2582       $rsa_module = $conf->config('encryptionmodule');
2583     }
2584
2585     if (!$rsa_loaded) {
2586         eval ("require $rsa_module"); # No need to import the namespace
2587         $rsa_loaded++;
2588     }
2589     # Initialize Encryption
2590     if ($conf->exists('encryptionpublickey') && $conf->config_binary('encryptionpublickey') ne '') {
2591       my $public_key = join("\n",$conf->config('encryptionpublickey'));
2592       $rsa_encrypt = $rsa_module->new_public_key($public_key);
2593     }
2594
2595     # Intitalize Decryption
2596     if ($conf->exists('encryptionprivatekey') && $conf->config_binary('encryptionprivatekey') ne '') {
2597       my $private_key = join("\n",$conf->config('encryptionprivatekey'));
2598       $rsa_decrypt = $rsa_module->new_private_key($private_key);
2599     }
2600 }
2601
2602 =item h_search ACTION
2603
2604 Given an ACTION, either "insert", or "delete", returns the appropriate history
2605 record corresponding to this record, if any.
2606
2607 =cut
2608
2609 sub h_search {
2610   my( $self, $action ) = @_;
2611
2612   my $table = $self->table;
2613   $table =~ s/^h_//;
2614
2615   my $primary_key = dbdef->table($table)->primary_key;
2616
2617   qsearchs({
2618     'table'   => "h_$table",
2619     'hashref' => { $primary_key     => $self->$primary_key(),
2620                    'history_action' => $action,
2621                  },
2622   });
2623
2624 }
2625
2626 =item h_date ACTION
2627
2628 Given an ACTION, either "insert", or "delete", returns the timestamp of the
2629 appropriate history record corresponding to this record, if any.
2630
2631 =cut
2632
2633 sub h_date {
2634   my($self, $action) = @_;
2635   my $h = $self->h_search($action);
2636   $h ? $h->history_date : '';
2637 }
2638
2639 =back
2640
2641 =head1 SUBROUTINES
2642
2643 =over 4
2644
2645 =item real_fields [ TABLE ]
2646
2647 Returns a list of the real columns in the specified table.  Called only by
2648 fields() and other subroutines elsewhere in FS::Record.
2649
2650 =cut
2651
2652 sub real_fields {
2653   my $table = shift;
2654
2655   my($table_obj) = dbdef->table($table);
2656   confess "Unknown table $table" unless $table_obj;
2657   $table_obj->columns;
2658 }
2659
2660 =item _quote VALUE, TABLE, COLUMN
2661
2662 This is an internal function used to construct SQL statements.  It returns
2663 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
2664 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
2665
2666 =cut
2667
2668 sub _quote {
2669   my($value, $table, $column) = @_;
2670   my $column_obj = dbdef->table($table)->column($column);
2671   my $column_type = $column_obj->type;
2672   my $nullable = $column_obj->null;
2673
2674   warn "  $table.$column: $value ($column_type".
2675        ( $nullable ? ' NULL' : ' NOT NULL' ).
2676        ")\n" if $DEBUG > 2;
2677
2678   if ( $value eq '' && $nullable ) {
2679     'NULL'
2680   } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
2681     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
2682           "using 0 instead";
2683     0;
2684   } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
2685             ! $column_type =~ /(char|binary|text)$/i ) {
2686     $value;
2687   } else {
2688     dbh->quote($value);
2689   }
2690 }
2691
2692 =item hfields TABLE
2693
2694 This is deprecated.  Don't use it.
2695
2696 It returns a hash-type list with the fields of this record's table set true.
2697
2698 =cut
2699
2700 sub hfields {
2701   carp "warning: hfields is deprecated";
2702   my($table)=@_;
2703   my(%hash);
2704   foreach (fields($table)) {
2705     $hash{$_}=1;
2706   }
2707   \%hash;
2708 }
2709
2710 sub _dump {
2711   my($self)=@_;
2712   join("\n", map {
2713     "$_: ". $self->getfield($_). "|"
2714   } (fields($self->table)) );
2715 }
2716
2717 sub DESTROY { return; }
2718
2719 #sub DESTROY {
2720 #  my $self = shift;
2721 #  #use Carp qw(cluck);
2722 #  #cluck "DESTROYING $self";
2723 #  warn "DESTROYING $self";
2724 #}
2725
2726 #sub is_tainted {
2727 #             return ! eval { join('',@_), kill 0; 1; };
2728 #         }
2729
2730 =item str2time_sql [ DRIVER_NAME ]
2731
2732 Returns a function to convert to unix time based on database type, such as
2733 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql.  See
2734 the str2time_sql_closing method to return a closing string rather than just
2735 using a closing parenthesis as previously suggested.
2736
2737 You can pass an optional driver name such as "Pg", "mysql" or
2738 $dbh->{Driver}->{Name} to return a function for that database instead of
2739 the current database.
2740
2741 =cut
2742
2743 sub str2time_sql {
2744   my $driver = shift || driver_name;
2745
2746   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;
2747   return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
2748
2749   warn "warning: unknown database type $driver; guessing how to convert ".
2750        "dates to UNIX timestamps";
2751   return 'EXTRACT(EPOCH FROM ';
2752
2753 }
2754
2755 =item str2time_sql_closing [ DRIVER_NAME ]
2756
2757 Returns the closing suffix of a function to convert to unix time based on
2758 database type, such as ")::integer" for Pg or ")" for mysql.
2759
2760 You can pass an optional driver name such as "Pg", "mysql" or
2761 $dbh->{Driver}->{Name} to return a function for that database instead of
2762 the current database.
2763
2764 =cut
2765
2766 sub str2time_sql_closing {
2767   my $driver = shift || driver_name;
2768
2769   return ' )::INTEGER ' if $driver =~ /^Pg/i;
2770   return ' ) ';
2771 }
2772
2773 =back
2774
2775 =head1 BUGS
2776
2777 This module should probably be renamed, since much of the functionality is
2778 of general use.  It is not completely unlike Adapter::DBI (see below).
2779
2780 Exported qsearch and qsearchs should be deprecated in favor of method calls
2781 (against an FS::Record object like the old search and searchs that qsearch
2782 and qsearchs were on top of.)
2783
2784 The whole fields / hfields mess should be removed.
2785
2786 The various WHERE clauses should be subroutined.
2787
2788 table string should be deprecated in favor of DBIx::DBSchema::Table.
2789
2790 No doubt we could benefit from a Tied hash.  Documenting how exists / defined
2791 true maps to the database (and WHERE clauses) would also help.
2792
2793 The ut_ methods should ask the dbdef for a default length.
2794
2795 ut_sqltype (like ut_varchar) should all be defined
2796
2797 A fallback check method should be provided which uses the dbdef.
2798
2799 The ut_money method assumes money has two decimal digits.
2800
2801 The Pg money kludge in the new method only strips `$'.
2802
2803 The ut_phonen method only checks US-style phone numbers.
2804
2805 The _quote function should probably use ut_float instead of a regex.
2806
2807 All the subroutines probably should be methods, here or elsewhere.
2808
2809 Probably should borrow/use some dbdef methods where appropriate (like sub
2810 fields)
2811
2812 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
2813 or allow it to be set.  Working around it is ugly any way around - DBI should
2814 be fixed.  (only affects RDBMS which return uppercase column names)
2815
2816 ut_zip should take an optional country like ut_phone.
2817
2818 =head1 SEE ALSO
2819
2820 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
2821
2822 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
2823
2824 http://poop.sf.net/
2825
2826 =cut
2827
2828 1;
2829