FS/FS/Record.pm

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