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