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