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