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