FS/FS/Record.pm

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