FS/FS/Record.pm

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