FS/FS/Record.pm

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