FS/FS/Record.pm

   1 package FS::Record;
   2 use base qw( Exporter );
   3
   4 use strict;
   5 use vars qw( $AUTOLOAD
   6              %virtual_fields_cache %fk_method_cache
   7              $money_char $lat_lower $lon_upper
   8            );
   9 use Carp qw(carp cluck croak confess);
  10 use Scalar::Util qw( blessed );
  11 use File::Slurp qw( slurp );
  12 use File::CounterFile;
  13 use Text::CSV_XS;
  14 use DBI qw(:sql_types);
  15 use DBIx::DBSchema 0.43; #0.43 for foreign keys
  16 use Locale::Country;
  17 use Locale::Currency;
  18 use NetAddr::IP; # for validation
  19 use FS::UID qw(dbh 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 our @encrypt_payby = qw( CARD DCRD CHEK DCHK );
  31
  32 #export dbdef for now... everything else expects to find it here
  33 our @EXPORT_OK = qw(
  34   dbh fields hfields qsearch qsearchs dbdef jsearch
  35   str2time_sql str2time_sql_closing regexp_sql not_regexp_sql
  36   concat_sql group_concat_sql
  37   midnight_sql
  38 );
  39
  40 our $DEBUG = 0;
  41 our $me = '[FS::Record]';
  42
  43 our $nowarn_identical = 0;
  44 our $nowarn_classload = 0;
  45 our $no_update_diff = 0;
  46 our $no_history = 0;
  47
  48 our $no_check_foreign = 1; #well, not inefficiently in perl by default anymore
  49
  50 my $rsa_module;
  51 my $rsa_loaded;
  52 my $rsa_encrypt;
  53 my $rsa_decrypt;
  54
  55 our $conf = '';
  56 our $conf_encryption = '';
  57 FS::UID->install_callback( sub {
  58
  59   eval "use FS::Conf;";
  60   die $@ if $@;
  61   $conf = FS::Conf->new;
  62   $conf_encryption = $conf->exists('encryption');
  63   $money_char = $conf->config('money_char') || '$';
  64   my $nw_coords = $conf->exists('geocode-require_nw_coordinates');
  65   $lat_lower = $nw_coords ? 1 : -90;
  66   $lon_upper = $nw_coords ? -1 : 180;
  67
  68   $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc;
  69
  70   if ( driver_name eq 'Pg' ) {
  71     eval "use DBD::Pg ':pg_types'";
  72     die $@ if $@;
  73   } else {
  74     eval "sub PG_BYTEA { die 'guru meditation #9: calling PG_BYTEA when not running Pg?'; }";
  75   }
  76
  77   foreach my $table ( dbdef->tables ) {
  78     $fk_method_cache{$table} = fk_methods($table);
  79   }
  80
  81 } );
  82
  83 =head1 NAME
  84
  85 FS::Record - Database record objects
  86
  87 =head1 SYNOPSIS
  88
  89     use FS::Record;
  90     use FS::Record qw(dbh fields qsearch qsearchs);
  91
  92     $record = new FS::Record 'table', \%hash;
  93     $record = new FS::Record 'table', { 'column' => 'value', ... };
  94
  95     $record  = qsearchs FS::Record 'table', \%hash;
  96     $record  = qsearchs FS::Record 'table', { 'column' => 'value', ... };
  97     @records = qsearch  FS::Record 'table', \%hash;
  98     @records = qsearch  FS::Record 'table', { 'column' => 'value', ... };
  99
 100     $table = $record->table;
 101     $dbdef_table = $record->dbdef_table;
 102
 103     $value = $record->get('column');
 104     $value = $record->getfield('column');
 105     $value = $record->column;
 106
 107     $record->set( 'column' => 'value' );
 108     $record->setfield( 'column' => 'value' );
 109     $record->column('value');
 110
 111     %hash = $record->hash;
 112
 113     $hashref = $record->hashref;
 114
 115     $error = $record->insert;
 116
 117     $error = $record->delete;
 118
 119     $error = $new_record->replace($old_record);
 120
 121     # external use deprecated - handled by the database (at least for Pg, mysql)
 122     $value = $record->unique('column');
 123
 124     $error = $record->ut_float('column');
 125     $error = $record->ut_floatn('column');
 126     $error = $record->ut_number('column');
 127     $error = $record->ut_numbern('column');
 128     $error = $record->ut_decimal('column');
 129     $error = $record->ut_decimaln('column');
 130     $error = $record->ut_snumber('column');
 131     $error = $record->ut_snumbern('column');
 132     $error = $record->ut_money('column');
 133     $error = $record->ut_text('column');
 134     $error = $record->ut_textn('column');
 135     $error = $record->ut_alpha('column');
 136     $error = $record->ut_alphan('column');
 137     $error = $record->ut_phonen('column');
 138     $error = $record->ut_anything('column');
 139     $error = $record->ut_name('column');
 140
 141     $quoted_value = _quote($value,'table','field');
 142
 143     #deprecated
 144     $fields = hfields('table');
 145     if ( $fields->{Field} ) { # etc.
 146
 147     @fields = fields 'table'; #as a subroutine
 148     @fields = $record->fields; #as a method call
 149
 150
 151 =head1 DESCRIPTION
 152
 153 (Mostly) object-oriented interface to database records.  Records are currently
 154 implemented on top of DBI.  FS::Record is intended as a base class for
 155 table-specific classes to inherit from, i.e. FS::cust_main.
 156
 157 =head1 CONSTRUCTORS
 158
 159 =over 4
 160
 161 =item new [ TABLE, ] HASHREF
 162
 163 Creates a new record.  It doesn't store it in the database, though.  See
 164 L<"insert"> for that.
 165
 166 Note that the object stores this hash reference, not a distinct copy of the
 167 hash it points to.  You can ask the object for a copy with the I<hash>
 168 method.
 169
 170 TABLE can only be omitted when a dervived class overrides the table method.
 171
 172 =cut
 173
 174 sub new {
 175   my $proto = shift;
 176   my $class = ref($proto) || $proto;
 177   my $self = {};
 178   bless ($self, $class);
 179
 180   unless ( defined ( $self->table ) ) {
 181     $self->{'Table'} = shift;
 182     carp "warning: FS::Record::new called with table name ". $self->{'Table'}
 183       unless $nowarn_classload;
 184   }
 185
 186   $self->{'Hash'} = shift;
 187
 188   foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {
 189     $self->{'Hash'}{$field}='';
 190   }
 191
 192   $self->_rebless if $self->can('_rebless');
 193
 194   $self->{'modified'} = 0;
 195
 196   $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
 197
 198   $self;
 199 }
 200
 201 sub new_or_cached {
 202   my $proto = shift;
 203   my $class = ref($proto) || $proto;
 204   my $self = {};
 205   bless ($self, $class);
 206
 207   $self->{'Table'} = shift unless defined ( $self->table );
 208
 209   my $hashref = $self->{'Hash'} = shift;
 210   my $cache = shift;
 211   if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) {
 212     my $obj = $cache->cache->{$hashref->{$cache->key}};
 213     $obj->_cache($hashref, $cache) if $obj->can('_cache');
 214     $obj;
 215   } else {
 216     $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache);
 217   }
 218
 219 }
 220
 221 sub create {
 222   my $proto = shift;
 223   my $class = ref($proto) || $proto;
 224   my $self = {};
 225   bless ($self, $class);
 226   if ( defined $self->table ) {
 227     cluck "create constructor is deprecated, use new!";
 228     $self->new(@_);
 229   } else {
 230     croak "FS::Record::create called (not from a subclass)!";
 231   }
 232 }
 233
 234 =item qsearch PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
 235
 236 Searches the database for all records matching (at least) the key/value pairs
 237 in HASHREF.  Returns all the records found as `FS::TABLE' objects if that
 238 module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
 239 objects.
 240
 241 The preferred usage is to pass a hash reference of named parameters:
 242
 243   @records = qsearch( {
 244                         'table'       => 'table_name',
 245                         'hashref'     => { 'field' => 'value'
 246                                            'field' => { 'op'    => '<',
 247                                                         'value' => '420',
 248                                                       },
 249                                          },
 250
 251                         #these are optional...
 252                         'select'      => '*',
 253                         'extra_sql'   => 'AND field = ? AND intfield = ?',
 254                         'extra_param' => [ 'value', [ 5, 'int' ] ],
 255                         'order_by'    => 'ORDER BY something',
 256                         #'cache_obj'   => '', #optional
 257                         'addl_from'   => 'LEFT JOIN othtable USING ( field )',
 258                         'debug'       => 1,
 259                       }
 260                     );
 261
 262 Much code still uses old-style positional parameters, this is also probably
 263 fine in the common case where there are only two parameters:
 264
 265   my @records = qsearch( 'table', { 'field' => 'value' } );
 266
 267 Also possible is an experimental LISTREF of PARAMS_HASHREFs for a UNION of
 268 the individual PARAMS_HASHREF queries
 269
 270 ###oops, argh, FS::Record::new only lets us create database fields.
 271 #Normal behaviour if SELECT is not specified is `*', as in
 272 #C<SELECT * FROM table WHERE ...>.  However, there is an experimental new
 273 #feature where you can specify SELECT - remember, the objects returned,
 274 #although blessed into the appropriate `FS::TABLE' package, will only have the
 275 #fields you specify.  This might have unwanted results if you then go calling
 276 #regular FS::TABLE methods
 277 #on it.
 278
 279 =cut
 280
 281 my %TYPE = (); #for debugging
 282
 283 sub _bind_type {
 284   my($type, $value) = @_;
 285
 286   my $bind_type = { TYPE => SQL_VARCHAR };
 287
 288   if ( $type =~ /(big)?(int|serial)/i && $value =~ /^-?\d+(\.\d+)?$/ ) {
 289
 290     $bind_type = { TYPE => SQL_INTEGER };
 291
 292   } elsif ( $type =~ /^bytea$/i || $type =~ /(blob|varbinary)/i ) {
 293
 294     if ( driver_name eq 'Pg' ) {
 295       no strict 'subs';
 296       $bind_type = { pg_type => PG_BYTEA };
 297     #} else {
 298     #  $bind_type = ? #SQL_VARCHAR could be fine?
 299     }
 300
 301   #DBD::Pg 1.49: Cannot bind ... unknown sql_type 6 with SQL_FLOAT
 302   #fixed by DBD::Pg 2.11.8
 303   #can change back to SQL_FLOAT in early-mid 2010, once everyone's upgraded
 304   #(make a Tron test first)
 305   } elsif ( _is_fs_float( $type, $value ) ) {
 306
 307     $bind_type = { TYPE => SQL_DECIMAL };
 308
 309   }
 310
 311   $bind_type;
 312
 313 }
 314
 315 sub _is_fs_float {
 316   my($type, $value) = @_;
 317   if ( ( $type =~ /(numeric)/i && $value =~ /^[+-]?\d+(\.\d+)?$/ ) ||
 318        ( $type =~ /(real|float4)/i && $value =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/)
 319      ) {
 320     return 1;
 321   }
 322   '';
 323 }
 324
 325 sub qsearch {
 326   my( @stable, @record, @cache );
 327   my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
 328   my @debug = ();
 329   my %union_options = ();
 330   if ( ref($_[0]) eq 'ARRAY' ) {
 331     my $optlist = shift;
 332     %union_options = @_;
 333     foreach my $href ( @$optlist ) {
 334       push @stable,      ( $href->{'table'} or die "table name is required" );
 335       push @record,      ( $href->{'hashref'}     || {} );
 336       push @select,      ( $href->{'select'}      || '*' );
 337       push @extra_sql,   ( $href->{'extra_sql'}   || '' );
 338       push @extra_param, ( $href->{'extra_param'} || [] );
 339       push @order_by,    ( $href->{'order_by'}    || '' );
 340       push @cache,       ( $href->{'cache_obj'}   || '' );
 341       push @addl_from,   ( $href->{'addl_from'}   || '' );
 342       push @debug,       ( $href->{'debug'}       || '' );
 343     }
 344     die "at least one hashref is required" unless scalar(@stable);
 345   } elsif ( ref($_[0]) eq 'HASH' ) {
 346     my $opt = shift;
 347     $stable[0]      = $opt->{'table'}       or die "table name is required";
 348     $record[0]      = $opt->{'hashref'}     || {};
 349     $select[0]      = $opt->{'select'}      || '*';
 350     $extra_sql[0]   = $opt->{'extra_sql'}   || '';
 351     $extra_param[0] = $opt->{'extra_param'} || [];
 352     $order_by[0]    = $opt->{'order_by'}    || '';
 353     $cache[0]       = $opt->{'cache_obj'}   || '';
 354     $addl_from[0]   = $opt->{'addl_from'}   || '';
 355     $debug[0]       = $opt->{'debug'}       || '';
 356   } else {
 357     ( $stable[0],
 358       $record[0],
 359       $select[0],
 360       $extra_sql[0],
 361       $cache[0],
 362       $addl_from[0]
 363     ) = @_;
 364     $select[0] ||= '*';
 365   }
 366   my $cache = $cache[0];
 367
 368   my @statement = ();
 369   my @value = ();
 370   my @bind_type = ();
 371   my $dbh = dbh;
 372   foreach my $stable ( @stable ) {
 373
 374     carp '->qsearch on cust_main called' if $stable eq 'cust_main' && $DEBUG;
 375
 376     #stop altering the caller's hashref
 377     my $record      = { %{ shift(@record) || {} } };#and be liberal in receipt
 378     my $select      = shift @select;
 379     my $extra_sql   = shift @extra_sql;
 380     my $extra_param = shift @extra_param;
 381     my $order_by    = shift @order_by;
 382     my $cache       = shift @cache;
 383     my $addl_from   = shift @addl_from;
 384     my $debug       = shift @debug;
 385
 386     #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
 387     #for jsearch
 388     $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
 389     $stable = $1;
 390
 391     my $table = $cache ? $cache->table : $stable;
 392     my $dbdef_table = dbdef->table($table)
 393       or die "No schema for table $table found - ".
 394              "do you need to run freeside-upgrade?";
 395     my $pkey = $dbdef_table->primary_key;
 396
 397     my @real_fields = grep exists($record->{$_}), real_fields($table);
 398
 399     my $statement .= "SELECT $select FROM $stable";
 400     $statement .= " $addl_from" if $addl_from;
 401     if ( @real_fields ) {
 402       $statement .= ' WHERE '. join(' AND ',
 403         get_real_fields($table, $record, \@real_fields));
 404     }
 405
 406     $statement .= " $extra_sql" if defined($extra_sql);
 407     $statement .= " $order_by"  if defined($order_by);
 408
 409     push @statement, $statement;
 410
 411     warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
 412
 413     foreach my $field (
 414       grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
 415     ) {
 416
 417       my $value = $record->{$field};
 418       my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
 419       $value = $value->{'value'} if ref($value);
 420       my $type = dbdef->table($table)->column($field)->type;
 421
 422       my $bind_type = _bind_type($type, $value);
 423
 424       #if ( $DEBUG > 2 ) {
 425       #  no strict 'refs';
 426       #  %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
 427       #    unless keys %TYPE;
 428       #  warn "  bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
 429       #}
 430
 431       push @value, $value;
 432       push @bind_type, $bind_type;
 433
 434     }
 435
 436     foreach my $param ( @$extra_param ) {
 437       my $bind_type = { TYPE => SQL_VARCHAR };
 438       my $value = $param;
 439       if ( ref($param) ) {
 440         $value = $param->[0];
 441         my $type = $param->[1];
 442         $bind_type = _bind_type($type, $value);
 443       }
 444       push @value, $value;
 445       push @bind_type, $bind_type;
 446     }
 447   }
 448
 449   my $statement = join( ' ) UNION ( ', @statement );
 450   $statement = "( $statement )" if scalar(@statement) > 1;
 451   $statement .= " $union_options{order_by}" if $union_options{order_by};
 452
 453   my $sth = $dbh->prepare($statement)
 454     or croak "$dbh->errstr doing $statement";
 455
 456   my $bind = 1;
 457   foreach my $value ( @value ) {
 458     my $bind_type = shift @bind_type;
 459     $sth->bind_param($bind++, $value, $bind_type );
 460   }
 461
 462 #  $sth->execute( map $record->{$_},
 463 #    grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
 464 #  ) or croak "Error executing \"$statement\": ". $sth->errstr;
 465
 466   my $ok = $sth->execute;
 467   if (!$ok) {
 468     my $error = "Error executing \"$statement\"";
 469     $error .= ' (' . join(', ', map {"'$_'"} @value) . ')' if @value;
 470     $error .= ': '. $sth->errstr;
 471     croak $error;
 472   }
 473
 474   my $table = $stable[0];
 475   my $pkey = '';
 476   $table = '' if grep { $_ ne $table } @stable;
 477   $pkey = dbdef->table($table)->primary_key if $table;
 478
 479   my %result;
 480   tie %result, "Tie::IxHash";
 481   my @stuff = @{ $sth->fetchall_arrayref( {} ) };
 482   if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
 483     %result = map { $_->{$pkey}, $_ } @stuff;
 484   } else {
 485     @result{@stuff} = @stuff;
 486   }
 487
 488   $sth->finish;
 489
 490   my @return;
 491   if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
 492     if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
 493       #derivied class didn't override new method, so this optimization is safe
 494       if ( $cache ) {
 495         @return = map {
 496           new_or_cached( "FS::$table", { %{$_} }, $cache )
 497         } values(%result);
 498       } else {
 499         @return = map {
 500           new( "FS::$table", { %{$_} } )
 501         } values(%result);
 502       }
 503     } else {
 504       #okay, its been tested
 505       # warn "untested code (class FS::$table uses custom new method)";
 506       @return = map {
 507         eval 'FS::'. $table. '->new( { %{$_} } )';
 508       } values(%result);
 509     }
 510
 511     # Check for encrypted fields and decrypt them.
 512    ## only in the local copy, not the cached object
 513     if ( $conf_encryption
 514          && eval '@FS::'. $table . '::encrypted_fields' ) {
 515       foreach my $record (@return) {
 516         foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
 517           next if $field eq 'payinfo'
 518                     && ($record->isa('FS::payinfo_transaction_Mixin')
 519                         || $record->isa('FS::payinfo_Mixin') )
 520                     && $record->payby
 521                     && !grep { $record->payby eq $_ } @encrypt_payby;
 522           # Set it directly... This may cause a problem in the future...
 523           $record->setfield($field, $record->decrypt($record->getfield($field)));
 524         }
 525       }
 526     }
 527   } else {
 528     cluck "warning: FS::$table not loaded; returning FS::Record objects"
 529       unless $nowarn_classload;
 530     @return = map {
 531       FS::Record->new( $table, { %{$_} } );
 532     } values(%result);
 533   }
 534   return @return;
 535 }
 536
 537 =item _query
 538
 539 Construct the SQL statement and parameter-binding list for qsearch.  Takes
 540 the qsearch parameters.
 541
 542 Returns a hash containing:
 543 'table':      The primary table name (if there is one).
 544 'statement':  The SQL statement itself.
 545 'bind_type':  An arrayref of bind types.
 546 'value':      An arrayref of parameter values.
 547 'cache':      The cache object, if one was passed.
 548
 549 =cut
 550
 551 sub _query {
 552   my( @stable, @record, @cache );
 553   my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
 554   my @debug = ();
 555   my $cursor = '';
 556   my %union_options = ();
 557   if ( ref($_[0]) eq 'ARRAY' ) {
 558     my $optlist = shift;
 559     %union_options = @_;
 560     foreach my $href ( @$optlist ) {
 561       push @stable,      ( $href->{'table'} or die "table name is required" );
 562       push @record,      ( $href->{'hashref'}     || {} );
 563       push @select,      ( $href->{'select'}      || '*' );
 564       push @extra_sql,   ( $href->{'extra_sql'}   || '' );
 565       push @extra_param, ( $href->{'extra_param'} || [] );
 566       push @order_by,    ( $href->{'order_by'}    || '' );
 567       push @cache,       ( $href->{'cache_obj'}   || '' );
 568       push @addl_from,   ( $href->{'addl_from'}   || '' );
 569       push @debug,       ( $href->{'debug'}       || '' );
 570     }
 571     die "at least one hashref is required" unless scalar(@stable);
 572   } elsif ( ref($_[0]) eq 'HASH' ) {
 573     my $opt = shift;
 574     $stable[0]      = $opt->{'table'}       or die "table name is required";
 575     $record[0]      = $opt->{'hashref'}     || {};
 576     $select[0]      = $opt->{'select'}      || '*';
 577     $extra_sql[0]   = $opt->{'extra_sql'}   || '';
 578     $extra_param[0] = $opt->{'extra_param'} || [];
 579     $order_by[0]    = $opt->{'order_by'}    || '';
 580     $cache[0]       = $opt->{'cache_obj'}   || '';
 581     $addl_from[0]   = $opt->{'addl_from'}   || '';
 582     $debug[0]       = $opt->{'debug'}       || '';
 583   } else {
 584     ( $stable[0],
 585       $record[0],
 586       $select[0],
 587       $extra_sql[0],
 588       $cache[0],
 589       $addl_from[0]
 590     ) = @_;
 591     $select[0] ||= '*';
 592   }
 593   my $cache = $cache[0];
 594
 595   my @statement = ();
 596   my @value = ();
 597   my @bind_type = ();
 598
 599   my $result_table = $stable[0];
 600   foreach my $stable ( @stable ) {
 601     #stop altering the caller's hashref
 602     my $record      = { %{ shift(@record) || {} } };#and be liberal in receipt
 603     my $select      = shift @select;
 604     my $extra_sql   = shift @extra_sql;
 605     my $extra_param = shift @extra_param;
 606     my $order_by    = shift @order_by;
 607     my $cache       = shift @cache;
 608     my $addl_from   = shift @addl_from;
 609     my $debug       = shift @debug;
 610
 611     #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
 612     #for jsearch
 613     $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
 614     $stable = $1;
 615
 616     $result_table = '' if $result_table ne $stable;
 617
 618     my $table = $cache ? $cache->table : $stable;
 619     my $dbdef_table = dbdef->table($table)
 620       or die "No schema for table $table found - ".
 621              "do you need to run freeside-upgrade?";
 622     my $pkey = $dbdef_table->primary_key;
 623
 624     my @real_fields = grep exists($record->{$_}), real_fields($table);
 625
 626     my $statement .= "SELECT $select FROM $stable";
 627     $statement .= " $addl_from" if $addl_from;
 628     if ( @real_fields ) {
 629       $statement .= ' WHERE '. join(' AND ',
 630         get_real_fields($table, $record, \@real_fields));
 631     }
 632
 633     $statement .= " $extra_sql" if defined($extra_sql);
 634     $statement .= " $order_by"  if defined($order_by);
 635
 636     push @statement, $statement;
 637
 638     warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
 639
 640
 641     foreach my $field (
 642       grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
 643     ) {
 644
 645       my $value = $record->{$field};
 646       my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
 647       $value = $value->{'value'} if ref($value);
 648       my $type = dbdef->table($table)->column($field)->type;
 649
 650       my $bind_type = _bind_type($type, $value);
 651
 652       #if ( $DEBUG > 2 ) {
 653       #  no strict 'refs';
 654       #  %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
 655       #    unless keys %TYPE;
 656       #  warn "  bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
 657       #}
 658
 659       push @value, $value;
 660       push @bind_type, $bind_type;
 661
 662     }
 663
 664     foreach my $param ( @$extra_param ) {
 665       my $bind_type = { TYPE => SQL_VARCHAR };
 666       my $value = $param;
 667       if ( ref($param) ) {
 668         $value = $param->[0];
 669         my $type = $param->[1];
 670         $bind_type = _bind_type($type, $value);
 671       }
 672       push @value, $value;
 673       push @bind_type, $bind_type;
 674     }
 675   }
 676
 677   my $statement = join( ' ) UNION ( ', @statement );
 678   $statement = "( $statement )" if scalar(@statement) > 1;
 679   $statement .= " $union_options{order_by}" if $union_options{order_by};
 680
 681   return {
 682     statement => $statement,
 683     bind_type => \@bind_type,
 684     value     => \@value,
 685     table     => $result_table,
 686     cache     => $cache,
 687   };
 688 }
 689
 690 # qsearch should eventually use this
 691 sub _from_hashref {
 692   my ($table, $cache, @hashrefs) = @_;
 693   my @return;
 694   # XXX get rid of these string evals at some point
 695   # (when we have time to test it)
 696   # my $class = "FS::$table" if $table;
 697   # if ( $class and $class->isa('FS::Record') )
 698   #   if ( $class->can('new') eq \&new )
 699   #
 700   if ( $table && eval 'scalar(@FS::'. $table. '::ISA);' ) {
 701     if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
 702       #derivied class didn't override new method, so this optimization is safe
 703       if ( $cache ) {
 704         @return = map {
 705           new_or_cached( "FS::$table", { %{$_} }, $cache )
 706         } @hashrefs;
 707       } else {
 708         @return = map {
 709           new( "FS::$table", { %{$_} } )
 710         } @hashrefs;
 711       }
 712     } else {
 713       #okay, its been tested
 714       # warn "untested code (class FS::$table uses custom new method)";
 715       @return = map {
 716         eval 'FS::'. $table. '->new( { %{$_} } )';
 717       } @hashrefs;
 718     }
 719
 720     # Check for encrypted fields and decrypt them.
 721    ## only in the local copy, not the cached object
 722     if ( $conf_encryption
 723          && eval '@FS::'. $table . '::encrypted_fields' ) {
 724       foreach my $record (@return) {
 725         foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
 726           next if $field eq 'payinfo'
 727                     && ($record->isa('FS::payinfo_transaction_Mixin')
 728                         || $record->isa('FS::payinfo_Mixin') )
 729                     && $record->payby
 730                     && !grep { $record->payby eq $_ } @encrypt_payby;
 731           # Set it directly... This may cause a problem in the future...
 732           $record->setfield($field, $record->decrypt($record->getfield($field)));
 733         }
 734       }
 735     }
 736   } else {
 737     cluck "warning: FS::$table not loaded; returning FS::Record objects"
 738       unless $nowarn_classload;
 739     @return = map {
 740       FS::Record->new( $table, { %{$_} } );
 741     } @hashrefs;
 742   }
 743   return @return;
 744 }
 745
 746 sub get_real_fields {
 747   my $table = shift;
 748   my $record = shift;
 749   my $real_fields = shift;
 750
 751   ## could be optimized more for readability
 752   return (
 753     map {
 754
 755       my $op = '=';
 756       my $column = $_;
 757       my $table_column = "$table.$column";
 758       my $type = dbdef->table($table)->column($column)->type;
 759       my $value = $record->{$column};
 760       $value = $value->{'value'} if ref($value);
 761
 762       if ( ref($record->{$column}) ) {
 763         $op = $record->{$column}{'op'} if $record->{$column}{'op'};
 764         #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
 765         if ( uc($op) eq 'ILIKE' ) {
 766           $op = 'LIKE';
 767           $record->{$column}{'value'} = lc($record->{$column}{'value'});
 768           $table_column = "LOWER($table_column)";
 769         }
 770         $record->{$column} = $record->{$column}{'value'}
 771       }
 772
 773       if ( ! defined( $record->{$column} ) || $record->{$column} eq '' ) {
 774         if ( $op eq '=' ) {
 775           if ( driver_name eq 'Pg' ) {
 776             if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
 777               qq-( $table_column IS NULL )-;
 778             } else {
 779               qq-( $table_column IS NULL OR $table_column = '' )-;
 780             }
 781           } else {
 782             qq-( $table_column IS NULL OR $table_column = "" )-;
 783           }
 784         } elsif ( $op eq '!=' ) {
 785           if ( driver_name eq 'Pg' ) {
 786             if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
 787               qq-( $table_column IS NOT NULL )-;
 788             } else {
 789               qq-( $table_column IS NOT NULL AND $table_column != '' )-;
 790             }
 791           } else {
 792             qq-( $table_column IS NOT NULL AND $table_column != "" )-;
 793           }
 794         } else {
 795           if ( driver_name eq 'Pg' ) {
 796             qq-( $table_column $op '' )-;
 797           } else {
 798             qq-( $table_column $op "" )-;
 799           }
 800         }
 801       } elsif ( $op eq '!=' ) {
 802         qq-( $table_column IS NULL OR $table_column != ? )-;
 803       #if this needs to be re-enabled, it needs to use a custom op like
 804       #"APPROX=" or something (better name?, not '=', to avoid affecting other
 805       # searches
 806       #} elsif ( $op eq 'APPROX=' && _is_fs_float( $type, $value ) ) {
 807       #  ( "$table_column <= ?", "$table_column >= ?" );
 808       } else {
 809         "$table_column $op ?";
 810       }
 811
 812     } @{ $real_fields }
 813   );
 814 }
 815
 816 =item by_key PRIMARY_KEY_VALUE
 817
 818 This is a class method that returns the record with the given primary key
 819 value.  This method is only useful in FS::Record subclasses.  For example:
 820
 821   my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
 822
 823 is equivalent to:
 824
 825   my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
 826
 827 =cut
 828
 829 sub by_key {
 830   my ($class, $pkey_value) = @_;
 831
 832   my $table = $class->table
 833     or croak "No table for $class found";
 834
 835   my $dbdef_table = dbdef->table($table)
 836     or die "No schema for table $table found - ".
 837            "do you need to create it or run dbdef-create?";
 838   my $pkey = $dbdef_table->primary_key
 839     or die "No primary key for table $table";
 840
 841   return qsearchs($table, { $pkey => $pkey_value });
 842 }
 843
 844 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
 845
 846 Experimental JOINed search method.  Using this method, you can execute a
 847 single SELECT spanning multiple tables, and cache the results for subsequent
 848 method calls.  Interface will almost definately change in an incompatible
 849 fashion.
 850
 851 Arguments:
 852
 853 =cut
 854
 855 sub jsearch {
 856   my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
 857   my $cache = FS::SearchCache->new( $ptable, $pkey );
 858   my %saw;
 859   ( $cache,
 860     grep { !$saw{$_->getfield($pkey)}++ }
 861       qsearch($table, $record, $select, $extra_sql, $cache )
 862   );
 863 }
 864
 865 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
 866
 867 Same as qsearch, except that if more than one record matches, it B<carp>s but
 868 returns the first.  If this happens, you either made a logic error in asking
 869 for a single item, or your data is corrupted.
 870
 871 =cut
 872
 873 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
 874   my $table = $_[0];
 875   my(@result) = qsearch(@_);
 876   cluck "warning: Multiple records in scalar search ($table)"
 877     if scalar(@result) > 1;
 878   #should warn more vehemently if the search was on a primary key?
 879   scalar(@result) ? ($result[0]) : ();
 880 }
 881
 882 =back
 883
 884 =head1 METHODS
 885
 886 =over 4
 887
 888 =item table
 889
 890 Returns the table name.
 891
 892 =cut
 893
 894 sub table {
 895 #  cluck "warning: FS::Record::table deprecated; supply one in subclass!";
 896   my $self = shift;
 897   $self -> {'Table'};
 898 }
 899
 900 =item dbdef_table
 901
 902 Returns the DBIx::DBSchema::Table object for the table.
 903
 904 =cut
 905
 906 sub dbdef_table {
 907   my($self)=@_;
 908   my($table)=$self->table;
 909   dbdef->table($table);
 910 }
 911
 912 =item primary_key
 913
 914 Returns the primary key for the table.
 915
 916 =cut
 917
 918 sub primary_key {
 919   my $self = shift;
 920   my $pkey = $self->dbdef_table->primary_key;
 921 }
 922
 923 =item get, getfield COLUMN
 924
 925 Returns the value of the column/field/key COLUMN.
 926
 927 =cut
 928
 929 sub get {
 930   my($self,$field) = @_;
 931   # to avoid "Use of unitialized value" errors
 932   if ( defined ( $self->{Hash}->{$field} ) ) {
 933     $self->{Hash}->{$field};
 934   } else {
 935     '';
 936   }
 937 }
 938 sub getfield {
 939   my $self = shift;
 940   $self->get(@_);
 941 }
 942
 943 =item set, setfield COLUMN, VALUE
 944
 945 Sets the value of the column/field/key COLUMN to VALUE.  Returns VALUE.
 946
 947 =cut
 948
 949 sub set {
 950   my($self,$field,$value) = @_;
 951   $self->{'modified'} = 1;
 952   $self->{'Hash'}->{$field} = $value;
 953 }
 954 sub setfield {
 955   my $self = shift;
 956   $self->set(@_);
 957 }
 958
 959 =item exists COLUMN
 960
 961 Returns true if the column/field/key COLUMN exists.
 962
 963 =cut
 964
 965 sub exists {
 966   my($self,$field) = @_;
 967   exists($self->{Hash}->{$field});
 968 }
 969
 970 =item AUTLOADED METHODS
 971
 972 $record->column is a synonym for $record->get('column');
 973
 974 $record->column('value') is a synonym for $record->set('column','value');
 975
 976 $record->foreign_table_name calls qsearchs and returns a single
 977 FS::foreign_table record (for tables referenced by a column of this table) or
 978 qsearch and returns an array of FS::foreign_table records (for tables
 979 referenced by a column in the foreign table).
 980
 981 =cut
 982
 983 # readable/safe
 984 sub AUTOLOAD {
 985   my($self,$value)=@_;
 986   my($field)=$AUTOLOAD;
 987   $field =~ s/.*://;
 988
 989   confess "errant AUTOLOAD $field for $self (arg $value)"
 990     unless blessed($self) && $self->can('setfield');
 991
 992   #$fk_method_cache{$self->table} ||= fk_methods($self->table);
 993   if ( exists($fk_method_cache{$self->table}->{$field}) ) {
 994
 995     my $fk_info = $fk_method_cache{$self->table}->{$field};
 996     my $method = $fk_info->{method} || 'qsearchs';
 997     my $table = $fk_info->{table} || $field;
 998     my $column = $fk_info->{column};
 999     my $foreign_column = $fk_info->{references} || $column;
1000
1001     eval "use FS::$table";
1002     die $@ if $@;
1003
1004     carp '->cust_main called' if $table eq 'cust_main' && $DEBUG;
1005
1006     my $pkey_value = $self->$column();
1007     my %search = ( $foreign_column => $pkey_value );
1008
1009     # FS::Record->$method() ?  they're actually just subs :/
1010     if ( $method eq 'qsearchs' ) {
1011       return $pkey_value ? qsearchs( $table, \%search ) : '';
1012     } elsif ( $method eq 'qsearch' ) {
1013       return $pkey_value ? qsearch(  $table, \%search ) : ();
1014     } else {
1015       die "unknown method $method";
1016     }
1017
1018   }
1019
1020   if ( defined($value) ) {
1021     $self->setfield($field,$value);
1022   } else {
1023     $self->getfield($field);
1024   }
1025 }
1026
1027 # efficient (also, old, doesn't support FK stuff)
1028 #sub AUTOLOAD {
1029 #  my $field = $AUTOLOAD;
1030 #  $field =~ s/.*://;
1031 #  if ( defined($_[1]) ) {
1032 #    $_[0]->setfield($field, $_[1]);
1033 #  } else {
1034 #    $_[0]->getfield($field);
1035 #  }
1036 #}
1037
1038 sub fk_methods {
1039   my $table = shift;
1040
1041   my %hash = ();
1042
1043   # foreign keys we reference in other tables
1044   foreach my $fk (dbdef->table($table)->foreign_keys) {
1045
1046     my $method = '';
1047     if ( scalar( @{$fk->columns} ) == 1 ) {
1048       if (    ! defined($fk->references)
1049            || ! @{$fk->references}
1050            || $fk->columns->[0] eq $fk->references->[0]
1051       ) {
1052         $method = $fk->table;
1053       } else {
1054         #some sort of hint in the table.pm or schema for methods not named
1055         # after their foreign table (well, not a whole lot different than
1056         # just providing a small subroutine...)
1057       }
1058
1059       if ( $method ) {
1060         $hash{$method} = { #fk_info
1061                            'method' => 'qsearchs',
1062                            'column' => $fk->columns->[0],
1063                            #'references' => $fk->references->[0],
1064                          };
1065       }
1066
1067     }
1068
1069   }
1070
1071   # foreign keys referenced in other tables to us
1072   #  (alas.  why we're cached.  still, might this loop better be done once at
1073   #   schema load time insetad of every time we AUTOLOAD a method on a new
1074   #   class?)
1075   foreach my $f_table ( dbdef->tables ) {
1076     foreach my $fk (dbdef->table($f_table)->foreign_keys) {
1077
1078       next unless $fk->table eq $table;
1079
1080       my $method = '';
1081       if ( scalar( @{$fk->columns} ) == 1 ) {
1082         if (    ! defined($fk->references)
1083              || ! @{$fk->references}
1084              || $fk->columns->[0] eq $fk->references->[0]
1085         ) {
1086           $method = $f_table;
1087         } else {
1088           #some sort of hint in the table.pm or schema for methods not named
1089           # after their foreign table (well, not a whole lot different than
1090           # just providing a small subroutine...)
1091         }
1092
1093         if ( $method ) {
1094           $hash{$method} = { #fk_info
1095                              'method' => 'qsearch',
1096                              'column' => $fk->columns->[0], #references||column
1097                              #'references' => $fk->column->[0],
1098                            };
1099         }
1100
1101       }
1102
1103     }
1104
1105   }
1106
1107   \%hash;
1108 }
1109
1110 =item hash
1111
1112 Returns a list of the column/value pairs, usually for assigning to a new hash.
1113
1114 To make a distinct duplicate of an FS::Record object, you can do:
1115
1116     $new = new FS::Record ( $old->table, { $old->hash } );
1117
1118 =cut
1119
1120 sub hash {
1121   my($self) = @_;
1122   confess $self. ' -> hash: Hash attribute is undefined'
1123     unless defined($self->{'Hash'});
1124   %{ $self->{'Hash'} };
1125 }
1126
1127 =item hashref
1128
1129 Returns a reference to the column/value hash.  This may be deprecated in the
1130 future; if there's a reason you can't just use the autoloaded or get/set
1131 methods, speak up.
1132
1133 =cut
1134
1135 sub hashref {
1136   my($self) = @_;
1137   $self->{'Hash'};
1138 }
1139
1140 #fallbacks/generics
1141
1142 sub API_getinfo {
1143   my $self = shift;
1144   +{ ( map { $_=>$self->$_ } $self->fields ),
1145    };
1146 }
1147
1148 sub API_insert {
1149   my( $class, %opt ) = @_;
1150   my $table = $class->table;
1151   my $self = $class->new( { map { $_ => $opt{$_} } fields($table) } );
1152   my $error = $self->insert;
1153   return +{ 'error' => $error } if $error;
1154   my $pkey = $self->pkey;
1155   return +{ 'error'       => '',
1156             'primary_key' => $pkey,
1157             $pkey         => $self->$pkey,
1158           };
1159 }
1160
1161 =item modified
1162
1163 Returns true if any of this object's values have been modified with set (or via
1164 an autoloaded method).  Doesn't yet recognize when you retreive a hashref and
1165 modify that.
1166
1167 =cut
1168
1169 sub modified {
1170   my $self = shift;
1171   $self->{'modified'};
1172 }
1173
1174 =item select_for_update
1175
1176 Selects this record with the SQL "FOR UPDATE" command.  This can be useful as
1177 a mutex.
1178
1179 =cut
1180
1181 sub select_for_update {
1182   my $self = shift;
1183   my $primary_key = $self->primary_key;
1184   qsearchs( {
1185     'select'    => '*',
1186     'table'     => $self->table,
1187     'hashref'   => { $primary_key => $self->$primary_key() },
1188     'extra_sql' => 'FOR UPDATE',
1189   } );
1190 }
1191
1192 =item lock_table
1193
1194 Locks this table with a database-driver specific lock method.  This is used
1195 as a mutex in order to do a duplicate search.
1196
1197 For PostgreSQL, does "LOCK TABLE tablename IN SHARE ROW EXCLUSIVE MODE".
1198
1199 For MySQL, does a SELECT FOR UPDATE on the duplicate_lock table.
1200
1201 Errors are fatal; no useful return value.
1202
1203 Note: To use this method for new tables other than svc_acct and svc_phone,
1204 edit freeside-upgrade and add those tables to the duplicate_lock list.
1205
1206 =cut
1207
1208 sub lock_table {
1209   my $self = shift;
1210   my $table = $self->table;
1211
1212   warn "$me locking $table table\n" if $DEBUG;
1213
1214   if ( driver_name =~ /^Pg/i ) {
1215
1216     dbh->do("LOCK TABLE $table IN SHARE ROW EXCLUSIVE MODE")
1217       or die dbh->errstr;
1218
1219   } elsif ( driver_name =~ /^mysql/i ) {
1220
1221     dbh->do("SELECT * FROM duplicate_lock
1222                WHERE lockname = '$table'
1223                FOR UPDATE"
1224            ) or die dbh->errstr;
1225
1226   } else {
1227
1228     die "unknown database ". driver_name. "; don't know how to lock table";
1229
1230   }
1231
1232   warn "$me acquired $table table lock\n" if $DEBUG;
1233
1234 }
1235
1236 =item insert
1237
1238 Inserts this record to the database.  If there is an error, returns the error,
1239 otherwise returns false.
1240
1241 =cut
1242
1243 sub insert {
1244   my $self = shift;
1245   my $saved = {};
1246
1247   warn "$self -> insert" if $DEBUG;
1248
1249   my $error = $self->check;
1250   return $error if $error;
1251
1252   #single-field non-null unique keys are given a value if empty
1253   #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
1254   foreach ( $self->dbdef_table->unique_singles) {
1255     next if $self->getfield($_);
1256     next if $self->dbdef_table->column($_)->null eq 'NULL';
1257     $self->unique($_);
1258   }
1259
1260   #and also the primary key, if the database isn't going to
1261   my $primary_key = $self->dbdef_table->primary_key;
1262   my $db_seq = 0;
1263   if ( $primary_key ) {
1264     my $col = $self->dbdef_table->column($primary_key);
1265
1266     $db_seq =
1267       uc($col->type) =~ /^(BIG)?SERIAL\d?/
1268       || ( driver_name eq 'Pg'
1269              && defined($col->default)
1270              && $col->quoted_default =~ /^nextval\(/i
1271          )
1272       || ( driver_name eq 'mysql'
1273              && defined($col->local)
1274              && $col->local =~ /AUTO_INCREMENT/i
1275          );
1276     $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
1277   }
1278
1279   my $table = $self->table;
1280
1281   # Encrypt before the database
1282   if (    defined(eval '@FS::'. $table . '::encrypted_fields')
1283        && scalar( eval '@FS::'. $table . '::encrypted_fields')
1284        && $conf->exists('encryption')
1285   ) {
1286     foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
1287       next if $field eq 'payinfo'
1288                 && ($self->isa('FS::payinfo_transaction_Mixin')
1289                     || $self->isa('FS::payinfo_Mixin') )
1290                 && $self->payby
1291                 && !grep { $self->payby eq $_ } @encrypt_payby;
1292       $saved->{$field} = $self->getfield($field);
1293       $self->setfield($field, $self->encrypt($self->getfield($field)));
1294     }
1295   }
1296
1297   #false laziness w/delete
1298   my @real_fields =
1299     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1300     real_fields($table)
1301   ;
1302   my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
1303   #eslaf
1304
1305   my $statement = "INSERT INTO $table ";
1306   if ( @real_fields ) {
1307     $statement .=
1308       "( ".
1309         join( ', ', @real_fields ).
1310       ") VALUES (".
1311         join( ', ', @values ).
1312        ")"
1313     ;
1314   } else {
1315     $statement .= 'DEFAULT VALUES';
1316   }
1317   warn "[debug]$me $statement\n" if $DEBUG > 1;
1318   my $sth = dbh->prepare($statement) or return dbh->errstr;
1319
1320   local $SIG{HUP} = 'IGNORE';
1321   local $SIG{INT} = 'IGNORE';
1322   local $SIG{QUIT} = 'IGNORE';
1323   local $SIG{TERM} = 'IGNORE';
1324   local $SIG{TSTP} = 'IGNORE';
1325   local $SIG{PIPE} = 'IGNORE';
1326
1327   $sth->execute or return $sth->errstr;
1328
1329   # get inserted id from the database, if applicable & needed
1330   if ( $db_seq && ! $self->getfield($primary_key) ) {
1331     warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
1332
1333     my $insertid = '';
1334
1335     if ( driver_name eq 'Pg' ) {
1336
1337       #my $oid = $sth->{'pg_oid_status'};
1338       #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
1339
1340       my $default = $self->dbdef_table->column($primary_key)->quoted_default;
1341       unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
1342         dbh->rollback if $FS::UID::AutoCommit;
1343         return "can't parse $table.$primary_key default value".
1344                " for sequence name: $default";
1345       }
1346       my $sequence = $1;
1347
1348       my $i_sql = "SELECT currval('$sequence')";
1349       my $i_sth = dbh->prepare($i_sql) or do {
1350         dbh->rollback if $FS::UID::AutoCommit;
1351         return dbh->errstr;
1352       };
1353       $i_sth->execute() or do { #$i_sth->execute($oid)
1354         dbh->rollback if $FS::UID::AutoCommit;
1355         return $i_sth->errstr;
1356       };
1357       $insertid = $i_sth->fetchrow_arrayref->[0];
1358
1359     } elsif ( driver_name eq 'mysql' ) {
1360
1361       $insertid = dbh->{'mysql_insertid'};
1362       # work around mysql_insertid being null some of the time, ala RT :/
1363       unless ( $insertid ) {
1364         warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
1365              "using SELECT LAST_INSERT_ID();";
1366         my $i_sql = "SELECT LAST_INSERT_ID()";
1367         my $i_sth = dbh->prepare($i_sql) or do {
1368           dbh->rollback if $FS::UID::AutoCommit;
1369           return dbh->errstr;
1370         };
1371         $i_sth->execute or do {
1372           dbh->rollback if $FS::UID::AutoCommit;
1373           return $i_sth->errstr;
1374         };
1375         $insertid = $i_sth->fetchrow_arrayref->[0];
1376       }
1377
1378     } else {
1379
1380       dbh->rollback if $FS::UID::AutoCommit;
1381       return "don't know how to retreive inserted ids from ". driver_name.
1382              ", try using counterfiles (maybe run dbdef-create?)";
1383
1384     }
1385
1386     $self->setfield($primary_key, $insertid);
1387
1388   }
1389
1390   my $h_sth;
1391   if ( defined( dbdef->table('h_'. $table) ) && ! $no_history ) {
1392     my $h_statement = $self->_h_statement('insert');
1393     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1394     $h_sth = dbh->prepare($h_statement) or do {
1395       dbh->rollback if $FS::UID::AutoCommit;
1396       return dbh->errstr;
1397     };
1398   } else {
1399     $h_sth = '';
1400   }
1401   $h_sth->execute or return $h_sth->errstr if $h_sth;
1402
1403   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1404
1405   # Now that it has been saved, reset the encrypted fields so that $new
1406   # can still be used.
1407   foreach my $field (keys %{$saved}) {
1408     $self->setfield($field, $saved->{$field});
1409   }
1410
1411   '';
1412 }
1413
1414 =item add
1415
1416 Depriciated (use insert instead).
1417
1418 =cut
1419
1420 sub add {
1421   cluck "warning: FS::Record::add deprecated!";
1422   insert @_; #call method in this scope
1423 }
1424
1425 =item delete
1426
1427 Delete this record from the database.  If there is an error, returns the error,
1428 otherwise returns false.
1429
1430 =cut
1431
1432 sub delete {
1433   my $self = shift;
1434
1435   my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
1436     map {
1437       $self->getfield($_) eq ''
1438         #? "( $_ IS NULL OR $_ = \"\" )"
1439         ? ( driver_name eq 'Pg'
1440               ? "$_ IS NULL"
1441               : "( $_ IS NULL OR $_ = \"\" )"
1442           )
1443         : "$_ = ". _quote($self->getfield($_),$self->table,$_)
1444     } ( $self->dbdef_table->primary_key )
1445           ? ( $self->dbdef_table->primary_key)
1446           : real_fields($self->table)
1447   );
1448   warn "[debug]$me $statement\n" if $DEBUG > 1;
1449   my $sth = dbh->prepare($statement) or return dbh->errstr;
1450
1451   my $h_sth;
1452   if ( defined dbdef->table('h_'. $self->table) ) {
1453     my $h_statement = $self->_h_statement('delete');
1454     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1455     $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
1456   } else {
1457     $h_sth = '';
1458   }
1459
1460   my $primary_key = $self->dbdef_table->primary_key;
1461
1462   local $SIG{HUP} = 'IGNORE';
1463   local $SIG{INT} = 'IGNORE';
1464   local $SIG{QUIT} = 'IGNORE';
1465   local $SIG{TERM} = 'IGNORE';
1466   local $SIG{TSTP} = 'IGNORE';
1467   local $SIG{PIPE} = 'IGNORE';
1468
1469   my $rc = $sth->execute or return $sth->errstr;
1470   #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1471   $h_sth->execute or return $h_sth->errstr if $h_sth;
1472
1473   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1474
1475   #no need to needlessly destoy the data either (causes problems actually)
1476   #undef $self; #no need to keep object!
1477
1478   '';
1479 }
1480
1481 =item del
1482
1483 Depriciated (use delete instead).
1484
1485 =cut
1486
1487 sub del {
1488   cluck "warning: FS::Record::del deprecated!";
1489   &delete(@_); #call method in this scope
1490 }
1491
1492 =item replace OLD_RECORD
1493
1494 Replace the OLD_RECORD with this one in the database.  If there is an error,
1495 returns the error, otherwise returns false.
1496
1497 =cut
1498
1499 sub replace {
1500   my ($new, $old) = (shift, shift);
1501
1502   $old = $new->replace_old unless defined($old);
1503
1504   warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1505
1506   if ( $new->can('replace_check') ) {
1507     my $error = $new->replace_check($old);
1508     return $error if $error;
1509   }
1510
1511   return "Records not in same table!" unless $new->table eq $old->table;
1512
1513   my $primary_key = $old->dbdef_table->primary_key;
1514   return "Can't change primary key $primary_key ".
1515          'from '. $old->getfield($primary_key).
1516          ' to ' . $new->getfield($primary_key)
1517     if $primary_key
1518        && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1519
1520   my $error = $new->check;
1521   return $error if $error;
1522
1523   # Encrypt for replace
1524   my $saved = {};
1525   if (    $conf->exists('encryption')
1526        && defined(eval '@FS::'. $new->table . '::encrypted_fields')
1527        && scalar( eval '@FS::'. $new->table . '::encrypted_fields')
1528   ) {
1529     foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1530       next if $field eq 'payinfo'
1531                 && ($new->isa('FS::payinfo_transaction_Mixin')
1532                     || $new->isa('FS::payinfo_Mixin') )
1533                 && $new->payby
1534                 && !grep { $new->payby eq $_ } @encrypt_payby;
1535       $saved->{$field} = $new->getfield($field);
1536       $new->setfield($field, $new->encrypt($new->getfield($field)));
1537     }
1538   }
1539
1540   #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1541   my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1542                    ? ($_, $new->getfield($_)) : () } $old->fields;
1543
1544   unless (keys(%diff) || $no_update_diff ) {
1545     carp "[warning]$me ". ref($new)."->replace ".
1546            ( $primary_key ? "$primary_key ".$new->get($primary_key) : '' ).
1547          ": records identical"
1548       unless $nowarn_identical;
1549     return '';
1550   }
1551
1552   my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1553     map {
1554       "$_ = ". _quote($new->getfield($_),$old->table,$_)
1555     } real_fields($old->table)
1556   ). ' WHERE '.
1557     join(' AND ',
1558       map {
1559
1560         if ( $old->getfield($_) eq '' ) {
1561
1562          #false laziness w/qsearch
1563          if ( driver_name eq 'Pg' ) {
1564             my $type = $old->dbdef_table->column($_)->type;
1565             if ( $type =~ /(int|(big)?serial)/i ) {
1566               qq-( $_ IS NULL )-;
1567             } else {
1568               qq-( $_ IS NULL OR $_ = '' )-;
1569             }
1570           } else {
1571             qq-( $_ IS NULL OR $_ = "" )-;
1572           }
1573
1574         } else {
1575           "$_ = ". _quote($old->getfield($_),$old->table,$_);
1576         }
1577
1578       } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1579     )
1580   ;
1581   warn "[debug]$me $statement\n" if $DEBUG > 1;
1582   my $sth = dbh->prepare($statement) or return dbh->errstr;
1583
1584   my $h_old_sth;
1585   if ( defined dbdef->table('h_'. $old->table) ) {
1586     my $h_old_statement = $old->_h_statement('replace_old');
1587     warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1588     $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1589   } else {
1590     $h_old_sth = '';
1591   }
1592
1593   my $h_new_sth;
1594   if ( defined dbdef->table('h_'. $new->table) ) {
1595     my $h_new_statement = $new->_h_statement('replace_new');
1596     warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1597     $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1598   } else {
1599     $h_new_sth = '';
1600   }
1601
1602   local $SIG{HUP} = 'IGNORE';
1603   local $SIG{INT} = 'IGNORE';
1604   local $SIG{QUIT} = 'IGNORE';
1605   local $SIG{TERM} = 'IGNORE';
1606   local $SIG{TSTP} = 'IGNORE';
1607   local $SIG{PIPE} = 'IGNORE';
1608
1609   my $rc = $sth->execute or return $sth->errstr;
1610   #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1611   $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1612   $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1613
1614   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1615
1616   # Now that it has been saved, reset the encrypted fields so that $new
1617   # can still be used.
1618   foreach my $field (keys %{$saved}) {
1619     $new->setfield($field, $saved->{$field});
1620   }
1621
1622   '';
1623
1624 }
1625
1626 sub replace_old {
1627   my( $self ) = shift;
1628   warn "[$me] replace called with no arguments; autoloading old record\n"
1629     if $DEBUG;
1630
1631   my $primary_key = $self->dbdef_table->primary_key;
1632   if ( $primary_key ) {
1633     $self->by_key( $self->$primary_key() ) #this is what's returned
1634       or croak "can't find ". $self->table. ".$primary_key ".
1635         $self->$primary_key();
1636   } else {
1637     croak $self->table. " has no primary key; pass old record as argument";
1638   }
1639
1640 }
1641
1642 =item rep
1643
1644 Depriciated (use replace instead).
1645
1646 =cut
1647
1648 sub rep {
1649   cluck "warning: FS::Record::rep deprecated!";
1650   replace @_; #call method in this scope
1651 }
1652
1653 =item check
1654
1655 Checks custom fields. Subclasses should still provide a check method to validate
1656 non-custom fields, etc., and call this method via $self->SUPER::check.
1657
1658 =cut
1659
1660 sub check {
1661     my $self = shift;
1662     foreach my $field ($self->virtual_fields) {
1663         my $error = $self->ut_textn($field);
1664         return $error if $error;
1665     }
1666     '';
1667 }
1668
1669 =item virtual_fields [ TABLE ]
1670
1671 Returns a list of virtual fields defined for the table.  This should not
1672 be exported, and should only be called as an instance or class method.
1673
1674 =cut
1675
1676 sub virtual_fields {
1677   my $self = shift;
1678   my $table;
1679   $table = $self->table or confess "virtual_fields called on non-table";
1680
1681   confess "Unknown table $table" unless dbdef->table($table);
1682
1683   return () unless dbdef->table('part_virtual_field');
1684
1685   unless ( $virtual_fields_cache{$table} ) {
1686     my $concat = [ "'cf_'", "name" ];
1687     my $query = "SELECT ".concat_sql($concat).' from part_virtual_field ' .
1688                 "WHERE dbtable = '$table'";
1689     my $dbh = dbh;
1690     my $result = $dbh->selectcol_arrayref($query);
1691     confess "Error executing virtual fields query: $query: ". $dbh->errstr
1692       if $dbh->err;
1693     $virtual_fields_cache{$table} = $result;
1694   }
1695
1696   @{$virtual_fields_cache{$table}};
1697
1698 }
1699
1700 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
1701
1702 Processes a batch import as a queued JSRPC job
1703
1704 JOB is an FS::queue entry.
1705
1706 OPTIONS_HASHREF can have the following keys:
1707
1708 =over 4
1709
1710 =item table
1711
1712 Table name (required).
1713
1714 =item params
1715
1716 Arrayref of field names for static fields.  They will be given values from the
1717 PARAMS hashref and passed as a "params" hashref to batch_import.
1718
1719 =item formats
1720
1721 Formats hashref.  Keys are field names, values are listrefs that define the
1722 format.
1723
1724 Each listref value can be a column name or a code reference.  Coderefs are run
1725 with the row object, data and a FS::Conf object as the three parameters.
1726 For example, this coderef does the same thing as using the "columnname" string:
1727
1728   sub {
1729     my( $record, $data, $conf ) = @_;
1730     $record->columnname( $data );
1731   },
1732
1733 Coderefs are run after all "column name" fields are assigned.
1734
1735 =item format_types
1736
1737 Optional format hashref of types.  Keys are field names, values are "csv",
1738 "xls" or "fixedlength".  Overrides automatic determination of file type
1739 from extension.
1740
1741 =item format_headers
1742
1743 Optional format hashref of header lines.  Keys are field names, values are 0
1744 for no header, 1 to ignore the first line, or to higher numbers to ignore that
1745 number of lines.
1746
1747 =item format_sep_chars
1748
1749 Optional format hashref of CSV sep_chars.  Keys are field names, values are the
1750 CSV separation character.
1751
1752 =item format_fixedlenth_formats
1753
1754 Optional format hashref of fixed length format defintiions.  Keys are field
1755 names, values Parse::FixedLength listrefs of field definitions.
1756
1757 =item default_csv
1758
1759 Set true to default to CSV file type if the filename does not contain a
1760 recognizable ".csv" or ".xls" extension (and type is not pre-specified by
1761 format_types).
1762
1763 =back
1764
1765 PARAMS is a hashref (or base64-encoded Storable hashref) containing the
1766 POSTed data.  It must contain the field "uploaded files", generated by
1767 /elements/file-upload.html and containing the list of uploaded files.
1768 Currently only supports a single file named "file".
1769
1770 =cut
1771
1772 use Data::Dumper;
1773 sub process_batch_import {
1774   my($job, $opt, $param) = @_;
1775
1776   my $table = $opt->{table};
1777   my @pass_params = $opt->{params} ? @{ $opt->{params} } : ();
1778   my %formats = %{ $opt->{formats} };
1779
1780   warn Dumper($param) if $DEBUG;
1781
1782   my $files = $param->{'uploaded_files'}
1783     or die "No files provided.\n";
1784
1785   my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
1786
1787   my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
1788   my $file = $dir. $files{'file'};
1789
1790   my %iopt = (
1791     #class-static
1792     table                      => $table,
1793     formats                    => \%formats,
1794     format_types               => $opt->{format_types},
1795     format_headers             => $opt->{format_headers},
1796     format_sep_chars           => $opt->{format_sep_chars},
1797     format_fixedlength_formats => $opt->{format_fixedlength_formats},
1798     format_xml_formats         => $opt->{format_xml_formats},
1799     format_asn_formats         => $opt->{format_asn_formats},
1800     format_row_callbacks       => $opt->{format_row_callbacks},
1801     #per-import
1802     job                        => $job,
1803     file                       => $file,
1804     #type                       => $type,
1805     format                     => $param->{format},
1806     params                     => { map { $_ => $param->{$_} } @pass_params },
1807     #?
1808     default_csv                => $opt->{default_csv},
1809     postinsert_callback        => $opt->{postinsert_callback},
1810   );
1811
1812   if ( $opt->{'batch_namecol'} ) {
1813     $iopt{'batch_namevalue'} = $param->{ $opt->{'batch_namecol'} };
1814     $iopt{$_} = $opt->{$_} foreach qw( batch_keycol batch_table batch_namecol );
1815   }
1816
1817   my $error = FS::Record::batch_import( \%iopt );
1818
1819   unlink $file;
1820
1821   die "$error\n" if $error;
1822 }
1823
1824 =item batch_import PARAM_HASHREF
1825
1826 Class method for batch imports.  Available params:
1827
1828 =over 4
1829
1830 =item table
1831
1832 =item format - usual way to specify import, with this format string selecting data from the formats and format_* info hashes
1833
1834 =item formats
1835
1836 =item format_types
1837
1838 =item format_headers
1839
1840 =item format_sep_chars
1841
1842 =item format_fixedlength_formats
1843
1844 =item format_row_callbacks
1845
1846 =item fields - Alternate way to specify import, specifying import fields directly as a listref
1847
1848 =item preinsert_callback
1849
1850 =item postinsert_callback
1851
1852 =item params
1853
1854 =item job
1855
1856 FS::queue object, will be updated with progress
1857
1858 =item file
1859
1860 =item type
1861
1862 csv, xls, fixedlength, xml
1863
1864 =item empty_ok
1865
1866 =back
1867
1868 =cut
1869
1870 use Data::Dumper;
1871 sub batch_import {
1872   my $param = shift;
1873
1874   warn "$me batch_import call with params: \n". Dumper($param)
1875     if $DEBUG;
1876
1877   my $table   = $param->{table};
1878
1879   my $job     = $param->{job};
1880   my $file    = $param->{file};
1881   my $params  = $param->{params} || {};
1882
1883   my $custnum_prefix = $conf->config('cust_main-custnum-display_prefix');
1884   my $custnum_length = $conf->config('cust_main-custnum-display_length') || 8;
1885
1886   my( $type, $header, $sep_char,
1887       $fixedlength_format, $xml_format, $asn_format,
1888       $parser_opt, $row_callback, @fields );
1889
1890   my $postinsert_callback = '';
1891   $postinsert_callback = $param->{'postinsert_callback'}
1892           if $param->{'postinsert_callback'};
1893   my $preinsert_callback = '';
1894   $preinsert_callback = $param->{'preinsert_callback'}
1895           if $param->{'preinsert_callback'};
1896
1897   if ( $param->{'format'} ) {
1898
1899     my $format  = $param->{'format'};
1900     my $formats = $param->{formats};
1901     die "unknown format $format" unless exists $formats->{ $format };
1902
1903     $type = $param->{'format_types'}
1904             ? $param->{'format_types'}{ $format }
1905             : $param->{type} || 'csv';
1906
1907
1908     $header = $param->{'format_headers'}
1909                ? $param->{'format_headers'}{ $param->{'format'} }
1910                : 0;
1911
1912     $sep_char = $param->{'format_sep_chars'}
1913                   ? $param->{'format_sep_chars'}{ $param->{'format'} }
1914                   : ',';
1915
1916     $fixedlength_format =
1917       $param->{'format_fixedlength_formats'}
1918         ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
1919         : '';
1920
1921     $parser_opt =
1922       $param->{'format_parser_opts'}
1923         ? $param->{'format_parser_opts'}{ $param->{'format'} }
1924         : {};
1925
1926     $xml_format =
1927       $param->{'format_xml_formats'}
1928         ? $param->{'format_xml_formats'}{ $param->{'format'} }
1929         : '';
1930
1931     $asn_format =
1932       $param->{'format_asn_formats'}
1933         ? $param->{'format_asn_formats'}{ $param->{'format'} }
1934         : '';
1935
1936     $row_callback =
1937       $param->{'format_row_callbacks'}
1938         ? $param->{'format_row_callbacks'}{ $param->{'format'} }
1939         : '';
1940
1941     @fields = @{ $formats->{ $format } };
1942
1943   } elsif ( $param->{'fields'} ) {
1944
1945     $type = ''; #infer from filename
1946     $header = 0;
1947     $sep_char = ',';
1948     $fixedlength_format = '';
1949     $row_callback = '';
1950     @fields = @{ $param->{'fields'} };
1951
1952   } else {
1953     die "neither format nor fields specified";
1954   }
1955
1956   #my $file    = $param->{file};
1957
1958   unless ( $type ) {
1959     if ( $file =~ /\.(\w+)$/i ) {
1960       $type = lc($1);
1961     } else {
1962       #or error out???
1963       warn "can't parse file type from filename $file; defaulting to CSV";
1964       $type = 'csv';
1965     }
1966     $type = 'csv'
1967       if $param->{'default_csv'} && $type ne 'xls';
1968   }
1969
1970
1971   my $row = 0;
1972   my $count;
1973   my $parser;
1974   my @buffer = ();
1975   my $asn_header_buffer;
1976   if ( $type eq 'csv' || $type eq 'fixedlength' ) {
1977
1978     if ( $type eq 'csv' ) {
1979
1980       $parser_opt->{'binary'} = 1;
1981       $parser_opt->{'sep_char'} = $sep_char if $sep_char;
1982       $parser = Text::CSV_XS->new($parser_opt);
1983
1984     } elsif ( $type eq 'fixedlength' ) {
1985
1986       eval "use Parse::FixedLength;";
1987       die $@ if $@;
1988       $parser = Parse::FixedLength->new($fixedlength_format, $parser_opt);
1989
1990     } else {
1991       die "Unknown file type $type\n";
1992     }
1993
1994     @buffer = split(/\r?\n/, slurp($file) );
1995     splice(@buffer, 0, ($header || 0) );
1996     $count = scalar(@buffer);
1997
1998   } elsif ( $type eq 'xls' ) {
1999
2000     eval "use Spreadsheet::ParseExcel;";
2001     die $@ if $@;
2002
2003     eval "use DateTime::Format::Excel;";
2004     #for now, just let the error be thrown if it is used, since only CDR
2005     # formats bill_west and troop use it, not other excel-parsing things
2006     #die $@ if $@;
2007
2008     my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
2009
2010     $parser = $excel->{Worksheet}[0]; #first sheet
2011
2012     $count = $parser->{MaxRow} || $parser->{MinRow};
2013     $count++;
2014
2015     $row = $header || 0;
2016
2017   } elsif ( $type eq 'xml' ) {
2018
2019     # FS::pay_batch
2020     eval "use XML::Simple;";
2021     die $@ if $@;
2022     my $xmlrow = $xml_format->{'xmlrow'};
2023     $parser = $xml_format->{'xmlkeys'};
2024     die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
2025     my $data = XML::Simple::XMLin(
2026       $file,
2027       'SuppressEmpty' => '', #sets empty values to ''
2028       'KeepRoot'      => 1,
2029     );
2030     my $rows = $data;
2031     $rows = $rows->{$_} foreach @$xmlrow;
2032     $rows = [ $rows ] if ref($rows) ne 'ARRAY';
2033     $count = @buffer = @$rows;
2034
2035   } elsif ( $type eq 'asn.1' ) {
2036
2037     eval "use Convert::ASN1";
2038     die $@ if $@;
2039
2040     my $asn = Convert::ASN1->new;
2041     $asn->prepare( $asn_format->{'spec'} ) or die $asn->error;
2042
2043     $parser = $asn->find( $asn_format->{'macro'} ) or die $asn->error;
2044
2045     my $data = slurp($file);
2046     my $asn_output = $parser->decode( $data )
2047       or return "No ". $asn_format->{'macro'}. " found\n";
2048
2049     $asn_header_buffer = &{ $asn_format->{'header_buffer'} }( $asn_output );
2050
2051     my $rows = &{ $asn_format->{'arrayref'} }( $asn_output );
2052     $count = @buffer = @$rows;
2053
2054   } else {
2055     die "Unknown file type $type\n";
2056   }
2057
2058   #my $columns;
2059
2060   local $SIG{HUP} = 'IGNORE';
2061   local $SIG{INT} = 'IGNORE';
2062   local $SIG{QUIT} = 'IGNORE';
2063   local $SIG{TERM} = 'IGNORE';
2064   local $SIG{TSTP} = 'IGNORE';
2065   local $SIG{PIPE} = 'IGNORE';
2066
2067   my $oldAutoCommit = $FS::UID::AutoCommit;
2068   local $FS::UID::AutoCommit = 0;
2069   my $dbh = dbh;
2070
2071   #my $params  = $param->{params} || {};
2072   if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) {
2073     my $batch_col   = $param->{'batch_keycol'};
2074
2075     my $batch_class = 'FS::'. $param->{'batch_table'};
2076     my $batch = $batch_class->new({
2077       $param->{'batch_namecol'} => $param->{'batch_namevalue'}
2078     });
2079     my $error = $batch->insert;
2080     if ( $error ) {
2081       $dbh->rollback if $oldAutoCommit;
2082       return "can't insert batch record: $error";
2083     }
2084     #primary key via dbdef? (so the column names don't have to match)
2085     my $batch_value = $batch->get( $param->{'batch_keycol'} );
2086
2087     $params->{ $batch_col } = $batch_value;
2088   }
2089
2090   #my $job     = $param->{job};
2091   my $line;
2092   my $imported = 0;
2093   my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
2094   while (1) {
2095
2096     my @columns = ();
2097     my %hash = %$params;
2098     if ( $type eq 'csv' ) {
2099
2100       last unless scalar(@buffer);
2101       $line = shift(@buffer);
2102
2103       next if $line =~ /^\s*$/; #skip empty lines
2104
2105       $line = &{$row_callback}($line) if $row_callback;
2106
2107       next if $line =~ /^\s*$/; #skip empty lines
2108
2109       $parser->parse($line) or do {
2110         $dbh->rollback if $oldAutoCommit;
2111         return "can't parse: ". $parser->error_input() . " " . $parser->error_diag;
2112       };
2113       @columns = $parser->fields();
2114
2115     } elsif ( $type eq 'fixedlength' ) {
2116
2117       last unless scalar(@buffer);
2118       $line = shift(@buffer);
2119
2120       @columns = $parser->parse($line);
2121
2122     } elsif ( $type eq 'xls' ) {
2123
2124       last if $row > ($parser->{MaxRow} || $parser->{MinRow})
2125            || ! $parser->{Cells}[$row];
2126
2127       my @row = @{ $parser->{Cells}[$row] };
2128       @columns = map $_->{Val}, @row;
2129
2130       #my $z = 'A';
2131       #warn $z++. ": $_\n" for @columns;
2132
2133     } elsif ( $type eq 'xml' ) {
2134
2135       # $parser = [ 'Column0Key', 'Column1Key' ... ]
2136       last unless scalar(@buffer);
2137       my $row = shift @buffer;
2138       @columns = @{ $row }{ @$parser };
2139
2140     } elsif ( $type eq 'asn.1' ) {
2141
2142       last unless scalar(@buffer);
2143       my $row = shift @buffer;
2144       &{ $asn_format->{row_callback} }( $row, $asn_header_buffer )
2145         if $asn_format->{row_callback};
2146       foreach my $key ( keys %{ $asn_format->{map} } ) {
2147         $hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer );
2148       }
2149
2150     } else {
2151       die "Unknown file type $type\n";
2152     }
2153
2154     my @later = ();
2155
2156     foreach my $field ( @fields ) {
2157
2158       my $value = shift @columns;
2159
2160       if ( ref($field) eq 'CODE' ) {
2161         #&{$field}(\%hash, $value);
2162         push @later, $field, $value;
2163       } else {
2164         #??? $hash{$field} = $value if length($value);
2165         $hash{$field} = $value if defined($value) && length($value);
2166       }
2167
2168     }
2169
2170     if ( $custnum_prefix && $hash{custnum} =~ /^$custnum_prefix(0*([1-9]\d*))$/
2171                          && length($1) == $custnum_length ) {
2172       $hash{custnum} = $2;
2173     }
2174
2175     #my $table   = $param->{table};
2176     my $class = "FS::$table";
2177
2178     my $record = $class->new( \%hash );
2179
2180     my $param = {};
2181     while ( scalar(@later) ) {
2182       my $sub = shift @later;
2183       my $data = shift @later;
2184       eval {
2185         &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
2186       };
2187       if ( $@ ) {
2188         $dbh->rollback if $oldAutoCommit;
2189         return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
2190       }
2191       last if exists( $param->{skiprow} );
2192     }
2193     next if exists( $param->{skiprow} );
2194
2195     if ( $preinsert_callback ) {
2196       my $error = &{$preinsert_callback}($record, $param);
2197       if ( $error ) {
2198         $dbh->rollback if $oldAutoCommit;
2199         return "preinsert_callback error". ( $line ? " for $line" : '' ).
2200                ": $error";
2201       }
2202       next if exists $param->{skiprow} && $param->{skiprow};
2203     }
2204
2205     my $error = $record->insert;
2206
2207     if ( $error ) {
2208       $dbh->rollback if $oldAutoCommit;
2209       return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
2210     }
2211
2212     $row++;
2213     $imported++;
2214
2215     if ( $postinsert_callback ) {
2216       my $error = &{$postinsert_callback}($record, $param);
2217       if ( $error ) {
2218         $dbh->rollback if $oldAutoCommit;
2219         return "postinsert_callback error". ( $line ? " for $line" : '' ).
2220                ": $error";
2221       }
2222     }
2223
2224     if ( $job && time - $min_sec > $last ) { #progress bar
2225       $job->update_statustext( int(100 * $imported / $count) );
2226       $last = time;
2227     }
2228
2229   }
2230
2231   unless ( $imported || $param->{empty_ok} ) {
2232     $dbh->rollback if $oldAutoCommit;
2233     return "Empty file!";
2234   }
2235
2236   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2237
2238   ''; #no error
2239
2240 }
2241
2242 sub _h_statement {
2243   my( $self, $action, $time ) = @_;
2244
2245   $time ||= time;
2246
2247   my %nohistory = map { $_=>1 } $self->nohistory_fields;
2248
2249   my @fields =
2250     grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
2251     real_fields($self->table);
2252   ;
2253
2254   # If we're encrypting then don't store the payinfo in the history
2255   if ( $conf && $conf->exists('encryption') && $self->table ne 'banned_pay' ) {
2256     @fields = grep { $_ ne 'payinfo' } @fields;
2257   }
2258
2259   my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
2260
2261   "INSERT INTO h_". $self->table. " ( ".
2262       join(', ', qw(history_date history_usernum history_action), @fields ).
2263     ") VALUES (".
2264       join(', ', $time,
2265                  $FS::CurrentUser::CurrentUser->usernum,
2266                  dbh->quote($action),
2267                  @values
2268       ).
2269     ")"
2270   ;
2271 }
2272
2273 =item unique COLUMN
2274
2275 B<Warning>: External use is B<deprecated>.
2276
2277 Replaces COLUMN in record with a unique number, using counters in the
2278 filesystem.  Used by the B<insert> method on single-field unique columns
2279 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
2280 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
2281
2282 Returns the new value.
2283
2284 =cut
2285
2286 sub unique {
2287   my($self,$field) = @_;
2288   my($table)=$self->table;
2289
2290   croak "Unique called on field $field, but it is ",
2291         $self->getfield($field),
2292         ", not null!"
2293     if $self->getfield($field);
2294
2295   #warn "table $table is tainted" if is_tainted($table);
2296   #warn "field $field is tainted" if is_tainted($field);
2297
2298   my($counter) = new File::CounterFile "$table.$field",0;
2299
2300   my $index = $counter->inc;
2301   $index = $counter->inc while qsearchs($table, { $field=>$index } );
2302
2303   $index =~ /^(\d*)$/;
2304   $index=$1;
2305
2306   $self->setfield($field,$index);
2307
2308 }
2309
2310 =item ut_float COLUMN
2311
2312 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May not be
2313 null.  If there is an error, returns the error, otherwise returns false.
2314
2315 =cut
2316
2317 sub ut_float {
2318   my($self,$field)=@_ ;
2319   ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
2320    $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
2321    $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
2322    $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
2323     or return "Illegal or empty (float) $field: ". $self->getfield($field);
2324   $self->setfield($field,$1);
2325   '';
2326 }
2327 =item ut_floatn COLUMN
2328
2329 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
2330 null.  If there is an error, returns the error, otherwise returns false.
2331
2332 =cut
2333
2334 #false laziness w/ut_ipn
2335 sub ut_floatn {
2336   my( $self, $field ) = @_;
2337   if ( $self->getfield($field) =~ /^()$/ ) {
2338     $self->setfield($field,'');
2339     '';
2340   } else {
2341     $self->ut_float($field);
2342   }
2343 }
2344
2345 =item ut_sfloat COLUMN
2346
2347 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
2348 May not be null.  If there is an error, returns the error, otherwise returns
2349 false.
2350
2351 =cut
2352
2353 sub ut_sfloat {
2354   my($self,$field)=@_ ;
2355   ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
2356    $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
2357    $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
2358    $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
2359     or return "Illegal or empty (float) $field: ". $self->getfield($field);
2360   $self->setfield($field,$1);
2361   '';
2362 }
2363 =item ut_sfloatn COLUMN
2364
2365 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
2366 null.  If there is an error, returns the error, otherwise returns false.
2367
2368 =cut
2369
2370 sub ut_sfloatn {
2371   my( $self, $field ) = @_;
2372   if ( $self->getfield($field) =~ /^()$/ ) {
2373     $self->setfield($field,'');
2374     '';
2375   } else {
2376     $self->ut_sfloat($field);
2377   }
2378 }
2379
2380 =item ut_snumber COLUMN
2381
2382 Check/untaint signed numeric data (whole numbers).  If there is an error,
2383 returns the error, otherwise returns false.
2384
2385 =cut
2386
2387 sub ut_snumber {
2388   my($self, $field) = @_;
2389   $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
2390     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2391   $self->setfield($field, "$1$2");
2392   '';
2393 }
2394
2395 =item ut_snumbern COLUMN
2396
2397 Check/untaint signed numeric data (whole numbers).  If there is an error,
2398 returns the error, otherwise returns false.
2399
2400 =cut
2401
2402 sub ut_snumbern {
2403   my($self, $field) = @_;
2404   $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
2405     or return "Illegal (numeric) $field: ". $self->getfield($field);
2406   if ($1) {
2407     return "Illegal (numeric) $field: ". $self->getfield($field)
2408       unless $2;
2409   }
2410   $self->setfield($field, "$1$2");
2411   '';
2412 }
2413
2414 =item ut_number COLUMN
2415
2416 Check/untaint simple numeric data (whole numbers).  May not be null.  If there
2417 is an error, returns the error, otherwise returns false.
2418
2419 =cut
2420
2421 sub ut_number {
2422   my($self,$field)=@_;
2423   $self->getfield($field) =~ /^\s*(\d+)\s*$/
2424     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2425   $self->setfield($field,$1);
2426   '';
2427 }
2428
2429 =item ut_numbern COLUMN
2430
2431 Check/untaint simple numeric data (whole numbers).  May be null.  If there is
2432 an error, returns the error, otherwise returns false.
2433
2434 =cut
2435
2436 sub ut_numbern {
2437   my($self,$field)=@_;
2438   $self->getfield($field) =~ /^\s*(\d*)\s*$/
2439     or return "Illegal (numeric) $field: ". $self->getfield($field);
2440   $self->setfield($field,$1);
2441   '';
2442 }
2443
2444 =item ut_decimal COLUMN[, DIGITS]
2445
2446 Check/untaint decimal numbers (up to DIGITS decimal places.  If there is an
2447 error, returns the error, otherwise returns false.
2448
2449 =item ut_decimaln COLUMN[, DIGITS]
2450
2451 Check/untaint decimal numbers.  May be null.  If there is an error, returns
2452 the error, otherwise returns false.
2453
2454 =cut
2455
2456 sub ut_decimal {
2457   my($self, $field, $digits) = @_;
2458   $digits ||= '';
2459   $self->getfield($field) =~ /^\s*(\d+(\.\d{0,$digits})?)\s*$/
2460     or return "Illegal or empty (decimal) $field: ".$self->getfield($field);
2461   $self->setfield($field, $1);
2462   '';
2463 }
2464
2465 sub ut_decimaln {
2466   my($self, $field, $digits) = @_;
2467   $self->getfield($field) =~ /^\s*(\d*(\.\d{0,$digits})?)\s*$/
2468     or return "Illegal (decimal) $field: ".$self->getfield($field);
2469   $self->setfield($field, $1);
2470   '';
2471 }
2472
2473 =item ut_money COLUMN
2474
2475 Check/untaint monetary numbers.  May be negative.  Set to 0 if null.  If there
2476 is an error, returns the error, otherwise returns false.
2477
2478 =cut
2479
2480 sub ut_money {
2481   my($self,$field)=@_;
2482
2483   if ( $self->getfield($field) eq '' ) {
2484     $self->setfield($field, 0);
2485   } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{1})\s*$/ ) {
2486     #handle one decimal place without barfing out
2487     $self->setfield($field, ( ($1||''). ($2||''). ($3.'0') ) || 0);
2488   } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ ) {
2489     $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
2490   } else {
2491     return "Illegal (money) $field: ". $self->getfield($field);
2492   }
2493
2494   '';
2495 }
2496
2497 =item ut_moneyn COLUMN
2498
2499 Check/untaint monetary numbers.  May be negative.  If there
2500 is an error, returns the error, otherwise returns false.
2501
2502 =cut
2503
2504 sub ut_moneyn {
2505   my($self,$field)=@_;
2506   if ($self->getfield($field) eq '') {
2507     $self->setfield($field, '');
2508     return '';
2509   }
2510   $self->ut_money($field);
2511 }
2512
2513 =item ut_currencyn COLUMN
2514
2515 Check/untaint currency indicators, such as USD or EUR.  May be null.  If there
2516 is an error, returns the error, otherwise returns false.
2517
2518 =cut
2519
2520 sub ut_currencyn {
2521   my($self, $field) = @_;
2522   if ($self->getfield($field) eq '') { #can be null
2523     $self->setfield($field, '');
2524     return '';
2525   }
2526   $self->ut_currency($field);
2527 }
2528
2529 =item ut_currency COLUMN
2530
2531 Check/untaint currency indicators, such as USD or EUR.  May not be null.  If
2532 there is an error, returns the error, otherwise returns false.
2533
2534 =cut
2535
2536 sub ut_currency {
2537   my($self, $field) = @_;
2538   my $value = uc( $self->getfield($field) );
2539   if ( code2currency($value) ) {
2540     $self->setfield($value);
2541   } else {
2542     return "Unknown currency $value";
2543   }
2544
2545   '';
2546 }
2547
2548 =item ut_text COLUMN
2549
2550 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2551 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2552 May not be null.  If there is an error, returns the error, otherwise returns
2553 false.
2554
2555 =cut
2556
2557 sub ut_text {
2558   my($self,$field)=@_;
2559   #warn "msgcat ". \&msgcat. "\n";
2560   #warn "notexist ". \&notexist. "\n";
2561   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
2562   # \p{Word} = alphanumerics, marks (diacritics), and connectors
2563   # see perldoc perluniprops
2564   $self->getfield($field)
2565     =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/
2566       or return gettext('illegal_or_empty_text'). " $field: ".
2567                  $self->getfield($field);
2568   $self->setfield($field,$1);
2569   '';
2570 }
2571
2572 =item ut_textn COLUMN
2573
2574 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2575 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2576 May be null.  If there is an error, returns the error, otherwise returns false.
2577
2578 =cut
2579
2580 sub ut_textn {
2581   my($self,$field)=@_;
2582   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2583   $self->ut_text($field);
2584 }
2585
2586 =item ut_alpha COLUMN
2587
2588 Check/untaint alphanumeric strings (no spaces).  May not be null.  If there is
2589 an error, returns the error, otherwise returns false.
2590
2591 =cut
2592
2593 sub ut_alpha {
2594   my($self,$field)=@_;
2595   $self->getfield($field) =~ /^(\w+)$/
2596     or return "Illegal or empty (alphanumeric) $field: ".
2597               $self->getfield($field);
2598   $self->setfield($field,$1);
2599   '';
2600 }
2601
2602 =item ut_alphan COLUMN
2603
2604 Check/untaint alphanumeric strings (no spaces).  May be null.  If there is an
2605 error, returns the error, otherwise returns false.
2606
2607 =cut
2608
2609 sub ut_alphan {
2610   my($self,$field)=@_;
2611   $self->getfield($field) =~ /^(\w*)$/
2612     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2613   $self->setfield($field,$1);
2614   '';
2615 }
2616
2617 =item ut_alphasn COLUMN
2618
2619 Check/untaint alphanumeric strings, spaces allowed.  May be null.  If there is
2620 an error, returns the error, otherwise returns false.
2621
2622 =cut
2623
2624 sub ut_alphasn {
2625   my($self,$field)=@_;
2626   $self->getfield($field) =~ /^([\w ]*)$/
2627     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2628   $self->setfield($field,$1);
2629   '';
2630 }
2631
2632
2633 =item ut_alpha_lower COLUMN
2634
2635 Check/untaint lowercase alphanumeric strings (no spaces).  May not be null.  If
2636 there is an error, returns the error, otherwise returns false.
2637
2638 =cut
2639
2640 sub ut_alpha_lower {
2641   my($self,$field)=@_;
2642   $self->getfield($field) =~ /[[:upper:]]/
2643     and return "Uppercase characters are not permitted in $field";
2644   $self->ut_alpha($field);
2645 }
2646
2647 =item ut_phonen COLUMN [ COUNTRY ]
2648
2649 Check/untaint phone numbers.  May be null.  If there is an error, returns
2650 the error, otherwise returns false.
2651
2652 Takes an optional two-letter ISO 3166-1 alpha-2 country code; without
2653 it or with unsupported countries, ut_phonen simply calls ut_alphan.
2654
2655 =cut
2656
2657 sub ut_phonen {
2658   my( $self, $field, $country ) = @_;
2659   return $self->ut_alphan($field) unless defined $country;
2660   my $phonen = $self->getfield($field);
2661   if ( $phonen eq '' ) {
2662     $self->setfield($field,'');
2663   } elsif ( $country eq 'US' || $country eq 'CA' ) {
2664     $phonen =~ s/\D//g;
2665     $phonen = $conf->config('cust_main-default_areacode').$phonen
2666       if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2667     $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2668       or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2669     $phonen = "$1-$2-$3";
2670     $phonen .= " x$4" if $4;
2671     $self->setfield($field,$phonen);
2672   } else {
2673     warn "warning: don't know how to check phone numbers for country $country";
2674     return $self->ut_textn($field);
2675   }
2676   '';
2677 }
2678
2679 =item ut_hex COLUMN
2680
2681 Check/untaint hexadecimal values.
2682
2683 =cut
2684
2685 sub ut_hex {
2686   my($self, $field) = @_;
2687   $self->getfield($field) =~ /^([\da-fA-F]+)$/
2688     or return "Illegal (hex) $field: ". $self->getfield($field);
2689   $self->setfield($field, uc($1));
2690   '';
2691 }
2692
2693 =item ut_hexn COLUMN
2694
2695 Check/untaint hexadecimal values.  May be null.
2696
2697 =cut
2698
2699 sub ut_hexn {
2700   my($self, $field) = @_;
2701   $self->getfield($field) =~ /^([\da-fA-F]*)$/
2702     or return "Illegal (hex) $field: ". $self->getfield($field);
2703   $self->setfield($field, uc($1));
2704   '';
2705 }
2706
2707 =item ut_mac_addr COLUMN
2708
2709 Check/untaint mac addresses.  May be null.
2710
2711 =cut
2712
2713 sub ut_mac_addr {
2714   my($self, $field) = @_;
2715
2716   my $mac = $self->get($field);
2717   $mac =~ s/\s+//g;
2718   $mac =~ s/://g;
2719   $self->set($field, $mac);
2720
2721   my $e = $self->ut_hex($field);
2722   return $e if $e;
2723
2724   return "Illegal (mac address) $field: ". $self->getfield($field)
2725     unless length($self->getfield($field)) == 12;
2726
2727   '';
2728
2729 }
2730
2731 =item ut_mac_addrn COLUMN
2732
2733 Check/untaint mac addresses.  May be null.
2734
2735 =cut
2736
2737 sub ut_mac_addrn {
2738   my($self, $field) = @_;
2739   ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
2740 }
2741
2742 =item ut_ip COLUMN
2743
2744 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2745 to 127.0.0.1.
2746
2747 =cut
2748
2749 sub ut_ip {
2750   my( $self, $field ) = @_;
2751   $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2752   $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2753     or return "Illegal (IP address) $field: ". $self->getfield($field);
2754   for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2755   $self->setfield($field, "$1.$2.$3.$4");
2756   '';
2757 }
2758
2759 =item ut_ipn COLUMN
2760
2761 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2762 to 127.0.0.1.  May be null.
2763
2764 =cut
2765
2766 sub ut_ipn {
2767   my( $self, $field ) = @_;
2768   if ( $self->getfield($field) =~ /^()$/ ) {
2769     $self->setfield($field,'');
2770     '';
2771   } else {
2772     $self->ut_ip($field);
2773   }
2774 }
2775
2776 =item ut_ip46 COLUMN
2777
2778 Check/untaint IPv4 or IPv6 address.
2779
2780 =cut
2781
2782 sub ut_ip46 {
2783   my( $self, $field ) = @_;
2784   my $ip = NetAddr::IP->new($self->getfield($field))
2785     or return "Illegal (IP address) $field: ".$self->getfield($field);
2786   $self->setfield($field, lc($ip->addr));
2787   return '';
2788 }
2789
2790 =item ut_ip46n
2791
2792 Check/untaint IPv6 or IPv6 address.  May be null.
2793
2794 =cut
2795
2796 sub ut_ip46n {
2797   my( $self, $field ) = @_;
2798   if ( $self->getfield($field) =~ /^$/ ) {
2799     $self->setfield($field, '');
2800     return '';
2801   }
2802   $self->ut_ip46($field);
2803 }
2804
2805 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2806
2807 Check/untaint coordinates.
2808 Accepts the following forms:
2809 DDD.DDDDD
2810 -DDD.DDDDD
2811 DDD MM.MMM
2812 -DDD MM.MMM
2813 DDD MM SS
2814 -DDD MM SS
2815 DDD MM MMM
2816 -DDD MM MMM
2817
2818 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2819 The latter form (that is, the MMM are thousands of minutes) is
2820 assumed if the "MMM" is exactly three digits or two digits > 59.
2821
2822 To be safe, just use the DDD.DDDDD form.
2823
2824 If LOWER or UPPER are specified, then the coordinate is checked
2825 for lower and upper bounds, respectively.
2826
2827 =cut
2828
2829 sub ut_coord {
2830   my ($self, $field) = (shift, shift);
2831
2832   my($lower, $upper);
2833   if ( $field =~ /latitude/ ) {
2834     $lower = $lat_lower;
2835     $upper = 90;
2836   } elsif ( $field =~ /longitude/ ) {
2837     $lower = -180;
2838     $upper = $lon_upper;
2839   }
2840
2841   my $coord = $self->getfield($field);
2842   my $neg = $coord =~ s/^(-)//;
2843
2844   my ($d, $m, $s) = (0, 0, 0);
2845
2846   if (
2847     (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2848     (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2849     (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2850   ) {
2851     $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2852     $m = $m / 60;
2853     if ($m > 59) {
2854       return "Invalid (coordinate with minutes > 59) $field: "
2855              . $self->getfield($field);
2856     }
2857
2858     $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2859
2860     if (defined($lower) and ($coord < $lower)) {
2861       return "Invalid (coordinate < $lower) $field: "
2862              . $self->getfield($field);;
2863     }
2864
2865     if (defined($upper) and ($coord > $upper)) {
2866       return "Invalid (coordinate > $upper) $field: "
2867              . $self->getfield($field);;
2868     }
2869
2870     $self->setfield($field, $coord);
2871     return '';
2872   }
2873
2874   return "Invalid (coordinate) $field: " . $self->getfield($field);
2875
2876 }
2877
2878 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2879
2880 Same as ut_coord, except optionally null.
2881
2882 =cut
2883
2884 sub ut_coordn {
2885
2886   my ($self, $field) = (shift, shift);
2887
2888   if ($self->getfield($field) =~ /^\s*$/) {
2889     return '';
2890   } else {
2891     return $self->ut_coord($field, @_);
2892   }
2893
2894 }
2895
2896 =item ut_domain COLUMN
2897
2898 Check/untaint host and domain names.  May not be null.
2899
2900 =cut
2901
2902 sub ut_domain {
2903   my( $self, $field ) = @_;
2904   #$self->getfield($field) =~/^(\w+\.)*\w+$/
2905   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2906     or return "Illegal (hostname) $field: ". $self->getfield($field);
2907   $self->setfield($field,$1);
2908   '';
2909 }
2910
2911 =item ut_domainn COLUMN
2912
2913 Check/untaint host and domain names.  May be null.
2914
2915 =cut
2916
2917 sub ut_domainn {
2918   my( $self, $field ) = @_;
2919   if ( $self->getfield($field) =~ /^()$/ ) {
2920     $self->setfield($field,'');
2921     '';
2922   } else {
2923     $self->ut_domain($field);
2924   }
2925 }
2926
2927 =item ut_name COLUMN
2928
2929 Check/untaint proper names; allows alphanumerics, spaces and the following
2930 punctuation: , . - '
2931
2932 May not be null.
2933
2934 =cut
2935
2936 sub ut_name {
2937   my( $self, $field ) = @_;
2938 #  warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n";
2939   $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/
2940     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
2941   my $name = $1;
2942   $name =~ s/^\s+//;
2943   $name =~ s/\s+$//;
2944   $name =~ s/\s+/ /g;
2945   $self->setfield($field, $name);
2946   '';
2947 }
2948
2949 =item ut_namen COLUMN
2950
2951 Check/untaint proper names; allows alphanumerics, spaces and the following
2952 punctuation: , . - '
2953
2954 May not be null.
2955
2956 =cut
2957
2958 sub ut_namen {
2959   my( $self, $field ) = @_;
2960   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2961   $self->ut_name($field);
2962 }
2963
2964 =item ut_zip COLUMN
2965
2966 Check/untaint zip codes.
2967
2968 =cut
2969
2970 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2971
2972 sub ut_zip {
2973   my( $self, $field, $country ) = @_;
2974
2975   if ( $country eq 'US' ) {
2976
2977     $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2978       or return gettext('illegal_zip'). " $field for country $country: ".
2979                 $self->getfield($field);
2980     $self->setfield($field, $1);
2981
2982   } elsif ( $country eq 'CA' ) {
2983
2984     $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2985       or return gettext('illegal_zip'). " $field for country $country: ".
2986                 $self->getfield($field);
2987     $self->setfield($field, "$1 $2");
2988
2989   } else {
2990
2991     if ( $self->getfield($field) =~ /^\s*$/
2992          && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
2993        )
2994     {
2995       $self->setfield($field,'');
2996     } else {
2997       $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/
2998         or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
2999       $self->setfield($field,$1);
3000     }
3001
3002   }
3003
3004   '';
3005 }
3006
3007 =item ut_country COLUMN
3008
3009 Check/untaint country codes.  Country names are changed to codes, if possible -
3010 see L<Locale::Country>.
3011
3012 =cut
3013
3014 sub ut_country {
3015   my( $self, $field ) = @_;
3016   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
3017     if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
3018          && country2code($1) ) {
3019       $self->setfield($field,uc(country2code($1)));
3020     }
3021   }
3022   $self->getfield($field) =~ /^(\w\w)$/
3023     or return "Illegal (country) $field: ". $self->getfield($field);
3024   $self->setfield($field,uc($1));
3025   '';
3026 }
3027
3028 =item ut_anything COLUMN
3029
3030 Untaints arbitrary data.  Be careful.
3031
3032 =cut
3033
3034 sub ut_anything {
3035   my( $self, $field ) = @_;
3036   $self->getfield($field) =~ /^(.*)$/s
3037     or return "Illegal $field: ". $self->getfield($field);
3038   $self->setfield($field,$1);
3039   '';
3040 }
3041
3042 =item ut_enum COLUMN CHOICES_ARRAYREF
3043
3044 Check/untaint a column, supplying all possible choices, like the "enum" type.
3045
3046 =cut
3047
3048 sub ut_enum {
3049   my( $self, $field, $choices ) = @_;
3050   foreach my $choice ( @$choices ) {
3051     if ( $self->getfield($field) eq $choice ) {
3052       $self->setfield($field, $choice);
3053       return '';
3054     }
3055   }
3056   return "Illegal (enum) field $field: ". $self->getfield($field);
3057 }
3058
3059 =item ut_enumn COLUMN CHOICES_ARRAYREF
3060
3061 Like ut_enum, except the null value is also allowed.
3062
3063 =cut
3064
3065 sub ut_enumn {
3066   my( $self, $field, $choices ) = @_;
3067   $self->getfield($field)
3068     ? $self->ut_enum($field, $choices)
3069     : '';
3070 }
3071
3072 =item ut_flag COLUMN
3073
3074 Check/untaint a column if it contains either an empty string or 'Y'.  This
3075 is the standard form for boolean flags in Freeside.
3076
3077 =cut
3078
3079 sub ut_flag {
3080   my( $self, $field ) = @_;
3081   my $value = uc($self->getfield($field));
3082   if ( $value eq '' or $value eq 'Y' ) {
3083     $self->setfield($field, $value);
3084     return '';
3085   }
3086   return "Illegal (flag) field $field: $value";
3087 }
3088
3089 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3090
3091 Check/untaint a foreign column key.  Call a regular ut_ method (like ut_number)
3092 on the column first.
3093
3094 =cut
3095
3096 sub ut_foreign_key {
3097   my( $self, $field, $table, $foreign ) = @_;
3098   return $self->ut_number($field) if $no_check_foreign;
3099   qsearchs($table, { $foreign => $self->getfield($field) })
3100     or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
3101               " in $table.$foreign";
3102   '';
3103 }
3104
3105 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3106
3107 Like ut_foreign_key, except the null value is also allowed.
3108
3109 =cut
3110
3111 sub ut_foreign_keyn {
3112   my( $self, $field, $table, $foreign ) = @_;
3113   $self->getfield($field)
3114     ? $self->ut_foreign_key($field, $table, $foreign)
3115     : '';
3116 }
3117
3118 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
3119
3120 Checks this column as an agentnum, taking into account the current users's
3121 ACLs.  NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
3122 right or rights allowing no agentnum.
3123
3124 =cut
3125
3126 sub ut_agentnum_acl {
3127   my( $self, $field ) = (shift, shift);
3128   my $null_acl = scalar(@_) ? shift : [];
3129   $null_acl = [ $null_acl ] unless ref($null_acl);
3130
3131   my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
3132   return "Illegal agentnum: $error" if $error;
3133
3134   my $curuser = $FS::CurrentUser::CurrentUser;
3135
3136   if ( $self->$field() ) {
3137
3138     return 'Access denied to agent '. $self->$field()
3139       unless $curuser->agentnum($self->$field());
3140
3141   } else {
3142
3143     return 'Access denied to global'
3144       unless grep $curuser->access_right($_), @$null_acl;
3145
3146   }
3147
3148   '';
3149
3150 }
3151
3152 =item fields [ TABLE ]
3153
3154 This is a wrapper for real_fields.  Code that called
3155 fields before should probably continue to call fields.
3156
3157 =cut
3158
3159 sub fields {
3160   my $something = shift;
3161   my $table;
3162   if($something->isa('FS::Record')) {
3163     $table = $something->table;
3164   } else {
3165     $table = $something;
3166     #$something = "FS::$table";
3167   }
3168   return (real_fields($table));
3169 }
3170
3171
3172 =item encrypt($value)
3173
3174 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
3175
3176 Returns the encrypted string.
3177
3178 You should generally not have to worry about calling this, as the system handles this for you.
3179
3180 =cut
3181
3182 sub encrypt {
3183   my ($self, $value) = @_;
3184   my $encrypted = $value;
3185
3186   if ($conf->exists('encryption')) {
3187     if ($self->is_encrypted($value)) {
3188       # Return the original value if it isn't plaintext.
3189       $encrypted = $value;
3190     } else {
3191       $self->loadRSA;
3192       if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
3193         # RSA doesn't like the empty string so let's pack it up
3194         # The database doesn't like the RSA data so uuencode it
3195         my $length = length($value)+1;
3196         $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
3197       } else {
3198         die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
3199       }
3200     }
3201   }
3202   return $encrypted;
3203 }
3204
3205 =item is_encrypted($value)
3206
3207 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
3208
3209 =cut
3210
3211
3212 sub is_encrypted {
3213   my ($self, $value) = @_;
3214   # could be more precise about it, but this will do for now
3215   $value =~ /^M/ && length($value) > 80;
3216 }
3217
3218 =item decrypt($value)
3219
3220 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
3221
3222 You should generally not have to worry about calling this, as the system handles this for you.
3223
3224 =cut
3225
3226 sub decrypt {
3227   my ($self,$value) = @_;
3228   my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
3229   if ($conf->exists('encryption') && $self->is_encrypted($value)) {
3230     $self->loadRSA;
3231     if (ref($rsa_decrypt) =~ /::RSA/) {
3232       my $encrypted = unpack ("u*", $value);
3233       $decrypted =  unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
3234       if ($@) {warn "Decryption Failed"};
3235     }
3236   }
3237   return $decrypted;
3238 }
3239
3240 sub loadRSA {
3241     my $self = shift;
3242     #Initialize the Module
3243     $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
3244
3245     if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') {
3246       $rsa_module = $conf->config('encryptionmodule');
3247     }
3248
3249     if (!$rsa_loaded) {
3250         eval ("require $rsa_module"); # No need to import the namespace
3251         $rsa_loaded++;
3252     }
3253     # Initialize Encryption
3254     if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') {
3255       my $public_key = join("\n",$conf->config('encryptionpublickey'));
3256       $rsa_encrypt = $rsa_module->new_public_key($public_key);
3257     }
3258
3259     # Intitalize Decryption
3260     if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') {
3261       my $private_key = join("\n",$conf->config('encryptionprivatekey'));
3262       $rsa_decrypt = $rsa_module->new_private_key($private_key);
3263     }
3264 }
3265
3266 =item h_search ACTION
3267
3268 Given an ACTION, either "insert", or "delete", returns the appropriate history
3269 record corresponding to this record, if any.
3270
3271 =cut
3272
3273 sub h_search {
3274   my( $self, $action ) = @_;
3275
3276   my $table = $self->table;
3277   $table =~ s/^h_//;
3278
3279   my $primary_key = dbdef->table($table)->primary_key;
3280
3281   qsearchs({
3282     'table'   => "h_$table",
3283     'hashref' => { $primary_key     => $self->$primary_key(),
3284                    'history_action' => $action,
3285                  },
3286   });
3287
3288 }
3289
3290 =item h_date ACTION
3291
3292 Given an ACTION, either "insert", or "delete", returns the timestamp of the
3293 appropriate history record corresponding to this record, if any.
3294
3295 =cut
3296
3297 sub h_date {
3298   my($self, $action) = @_;
3299   my $h = $self->h_search($action);
3300   $h ? $h->history_date : '';
3301 }
3302
3303 =item scalar_sql SQL [ PLACEHOLDER, ... ]
3304
3305 A class or object method.  Executes the sql statement represented by SQL and
3306 returns a scalar representing the result: the first column of the first row.
3307
3308 Dies on bogus SQL.  Returns an empty string if no row is returned.
3309
3310 Typically used for statments which return a single value such as "SELECT
3311 COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
3312
3313 =cut
3314
3315 sub scalar_sql {
3316   my($self, $sql) = (shift, shift);
3317   my $sth = dbh->prepare($sql) or die dbh->errstr;
3318   $sth->execute(@_)
3319     or die "Unexpected error executing statement $sql: ". $sth->errstr;
3320   my $row = $sth->fetchrow_arrayref or return '';
3321   my $scalar = $row->[0];
3322   defined($scalar) ? $scalar : '';
3323 }
3324
3325 =item count [ WHERE [, PLACEHOLDER ...] ]
3326
3327 Convenience method for the common case of "SELECT COUNT(*) FROM table",
3328 with optional WHERE.  Must be called as method on a class with an
3329 associated table.
3330
3331 =cut
3332
3333 sub count {
3334   my($self, $where) = (shift, shift);
3335   my $table = $self->table or die 'count called on object of class '.ref($self);
3336   my $sql = "SELECT COUNT(*) FROM $table";
3337   $sql .= " WHERE $where" if $where;
3338   $self->scalar_sql($sql, @_);
3339 }
3340
3341 =item row_exists [ WHERE [, PLACEHOLDER ...] ]
3342
3343 Convenience method for the common case of "SELECT 1 FROM table ... LIMIT 1"
3344 with optional (but almost always needed) WHERE.
3345
3346 =cut
3347
3348 sub row_exists {
3349   my($self, $where) = (shift, shift);
3350   my $table = $self->table or die 'row_exists called on object of class '.ref($self);
3351   my $sql = "SELECT 1 FROM $table";
3352   $sql .= " WHERE $where" if $where;
3353   $sql .= " LIMIT 1";
3354   $self->scalar_sql($sql, @_);
3355 }
3356
3357 =back
3358
3359 =head1 SUBROUTINES
3360
3361 =over 4
3362
3363 =item real_fields [ TABLE ]
3364
3365 Returns a list of the real columns in the specified table.  Called only by
3366 fields() and other subroutines elsewhere in FS::Record.
3367
3368 =cut
3369
3370 sub real_fields {
3371   my $table = shift;
3372
3373   my($table_obj) = dbdef->table($table);
3374   confess "Unknown table $table" unless $table_obj;
3375   $table_obj->columns;
3376 }
3377
3378 =item pvf FIELD_NAME
3379
3380 Returns the FS::part_virtual_field object corresponding to a field in the
3381 record (specified by FIELD_NAME).
3382
3383 =cut
3384
3385 sub pvf {
3386   my ($self, $name) = (shift, shift);
3387
3388   if(grep /^$name$/, $self->virtual_fields) {
3389     $name =~ s/^cf_//;
3390     my $concat = [ "'cf_'", "name" ];
3391     return qsearchs({   table   =>  'part_virtual_field',
3392                         hashref =>  { dbtable => $self->table,
3393                                       name    => $name
3394                                     },
3395                         select  =>  'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
3396                     });
3397   }
3398   ''
3399 }
3400
3401 =item _quote VALUE, TABLE, COLUMN
3402
3403 This is an internal function used to construct SQL statements.  It returns
3404 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
3405 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
3406
3407 =cut
3408
3409 sub _quote {
3410   my($value, $table, $column) = @_;
3411   my $column_obj = dbdef->table($table)->column($column);
3412   my $column_type = $column_obj->type;
3413   my $nullable = $column_obj->null;
3414
3415   utf8::upgrade($value);
3416
3417   warn "  $table.$column: $value ($column_type".
3418        ( $nullable ? ' NULL' : ' NOT NULL' ).
3419        ")\n" if $DEBUG > 2;
3420
3421   if ( $value eq '' && $nullable ) {
3422     'NULL';
3423   } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
3424     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
3425           "using 0 instead";
3426     0;
3427   } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
3428             ! $column_type =~ /(char|binary|text)$/i ) {
3429     $value;
3430   } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
3431            && driver_name eq 'Pg'
3432           )
3433   {
3434     no strict 'subs';
3435 #    dbh->quote($value, { pg_type => PG_BYTEA() }); # doesn't work right
3436     # Pg binary string quoting: convert each character to 3-digit octal prefixed with \\,
3437     # single-quote the whole mess, and put an "E" in front.
3438     return ("E'" . join('', map { sprintf('\\\\%03o', ord($_)) } split(//, $value) ) . "'");
3439   } else {
3440     dbh->quote($value);
3441   }
3442 }
3443
3444 =item hfields TABLE
3445
3446 This is deprecated.  Don't use it.
3447
3448 It returns a hash-type list with the fields of this record's table set true.
3449
3450 =cut
3451
3452 sub hfields {
3453   carp "warning: hfields is deprecated";
3454   my($table)=@_;
3455   my(%hash);
3456   foreach (fields($table)) {
3457     $hash{$_}=1;
3458   }
3459   \%hash;
3460 }
3461
3462 sub _dump {
3463   my($self)=@_;
3464   join("\n", map {
3465     "$_: ". $self->getfield($_). "|"
3466   } (fields($self->table)) );
3467 }
3468
3469 sub DESTROY { return; }
3470
3471 #sub DESTROY {
3472 #  my $self = shift;
3473 #  #use Carp qw(cluck);
3474 #  #cluck "DESTROYING $self";
3475 #  warn "DESTROYING $self";
3476 #}
3477
3478 #sub is_tainted {
3479 #             return ! eval { join('',@_), kill 0; 1; };
3480 #         }
3481
3482 =item str2time_sql [ DRIVER_NAME ]
3483
3484 Returns a function to convert to unix time based on database type, such as
3485 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql.  See
3486 the str2time_sql_closing method to return a closing string rather than just
3487 using a closing parenthesis as previously suggested.
3488
3489 You can pass an optional driver name such as "Pg", "mysql" or
3490 $dbh->{Driver}->{Name} to return a function for that database instead of
3491 the current database.
3492
3493 =cut
3494
3495 sub str2time_sql {
3496   my $driver = shift || driver_name;
3497
3498   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;
3499   return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
3500
3501   warn "warning: unknown database type $driver; guessing how to convert ".
3502        "dates to UNIX timestamps";
3503   return 'EXTRACT(EPOCH FROM ';
3504
3505 }
3506
3507 =item str2time_sql_closing [ DRIVER_NAME ]
3508
3509 Returns the closing suffix of a function to convert to unix time based on
3510 database type, such as ")::integer" for Pg or ")" for mysql.
3511
3512 You can pass an optional driver name such as "Pg", "mysql" or
3513 $dbh->{Driver}->{Name} to return a function for that database instead of
3514 the current database.
3515
3516 =cut
3517
3518 sub str2time_sql_closing {
3519   my $driver = shift || driver_name;
3520
3521   return ' )::INTEGER ' if $driver =~ /^Pg/i;
3522   return ' ) ';
3523 }
3524
3525 =item regexp_sql [ DRIVER_NAME ]
3526
3527 Returns the operator to do a regular expression comparison based on database
3528 type, such as '~' for Pg or 'REGEXP' for mysql.
3529
3530 You can pass an optional driver name such as "Pg", "mysql" or
3531 $dbh->{Driver}->{Name} to return a function for that database instead of
3532 the current database.
3533
3534 =cut
3535
3536 sub regexp_sql {
3537   my $driver = shift || driver_name;
3538
3539   return '~'      if $driver =~ /^Pg/i;
3540   return 'REGEXP' if $driver =~ /^mysql/i;
3541
3542   die "don't know how to use regular expressions in ". driver_name." databases";
3543
3544 }
3545
3546 =item not_regexp_sql [ DRIVER_NAME ]
3547
3548 Returns the operator to do a regular expression negation based on database
3549 type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
3550
3551 You can pass an optional driver name such as "Pg", "mysql" or
3552 $dbh->{Driver}->{Name} to return a function for that database instead of
3553 the current database.
3554
3555 =cut
3556
3557 sub not_regexp_sql {
3558   my $driver = shift || driver_name;
3559
3560   return '!~'         if $driver =~ /^Pg/i;
3561   return 'NOT REGEXP' if $driver =~ /^mysql/i;
3562
3563   die "don't know how to use regular expressions in ". driver_name." databases";
3564
3565 }
3566
3567 =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
3568
3569 Returns the items concatenated based on database type, using "CONCAT()" for
3570 mysql and " || " for Pg and other databases.
3571
3572 You can pass an optional driver name such as "Pg", "mysql" or
3573 $dbh->{Driver}->{Name} to return a function for that database instead of
3574 the current database.
3575
3576 =cut
3577
3578 sub concat_sql {
3579   my $driver = ref($_[0]) ? driver_name : shift;
3580   my $items = shift;
3581
3582   if ( $driver =~ /^mysql/i ) {
3583     'CONCAT('. join(',', @$items). ')';
3584   } else {
3585     join('||', @$items);
3586   }
3587
3588 }
3589
3590 =item group_concat_sql COLUMN, DELIMITER
3591
3592 Returns an SQL expression to concatenate an aggregate column, using
3593 GROUP_CONCAT() for mysql and array_to_string() and array_agg() for Pg.
3594
3595 =cut
3596
3597 sub group_concat_sql {
3598   my ($col, $delim) = @_;
3599   $delim = dbh->quote($delim);
3600   if ( driver_name() =~ /^mysql/i ) {
3601     # DISTINCT(foo) is valid as $col
3602     return "GROUP_CONCAT($col SEPARATOR $delim)";
3603   } else {
3604     return "array_to_string(array_agg($col), $delim)";
3605   }
3606 }
3607
3608 =item midnight_sql DATE
3609
3610 Returns an SQL expression to convert DATE (a unix timestamp) to midnight
3611 on that day in the system timezone, using the default driver name.
3612
3613 =cut
3614
3615 sub midnight_sql {
3616   my $driver = driver_name;
3617   my $expr = shift;
3618   if ( $driver =~ /^mysql/i ) {
3619     "UNIX_TIMESTAMP(DATE(FROM_UNIXTIME($expr)))";
3620   }
3621   else {
3622     "EXTRACT( EPOCH FROM DATE(TO_TIMESTAMP($expr)) )";
3623   }
3624 }
3625
3626 =back
3627
3628 =head1 BUGS
3629
3630 This module should probably be renamed, since much of the functionality is
3631 of general use.  It is not completely unlike Adapter::DBI (see below).
3632
3633 Exported qsearch and qsearchs should be deprecated in favor of method calls
3634 (against an FS::Record object like the old search and searchs that qsearch
3635 and qsearchs were on top of.)
3636
3637 The whole fields / hfields mess should be removed.
3638
3639 The various WHERE clauses should be subroutined.
3640
3641 table string should be deprecated in favor of DBIx::DBSchema::Table.
3642
3643 No doubt we could benefit from a Tied hash.  Documenting how exists / defined
3644 true maps to the database (and WHERE clauses) would also help.
3645
3646 The ut_ methods should ask the dbdef for a default length.
3647
3648 ut_sqltype (like ut_varchar) should all be defined
3649
3650 A fallback check method should be provided which uses the dbdef.
3651
3652 The ut_money method assumes money has two decimal digits.
3653
3654 The Pg money kludge in the new method only strips `$'.
3655
3656 The ut_phonen method only checks US-style phone numbers.
3657
3658 The _quote function should probably use ut_float instead of a regex.
3659
3660 All the subroutines probably should be methods, here or elsewhere.
3661
3662 Probably should borrow/use some dbdef methods where appropriate (like sub
3663 fields)
3664
3665 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
3666 or allow it to be set.  Working around it is ugly any way around - DBI should
3667 be fixed.  (only affects RDBMS which return uppercase column names)
3668
3669 ut_zip should take an optional country like ut_phone.
3670
3671 =head1 SEE ALSO
3672
3673 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
3674
3675 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
3676
3677 http://poop.sf.net/
3678
3679 =cut
3680
3681 1;
3682