FS/FS/Record.pm

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