eliminate some false laziness in FS::Misc::send_email vs. msg_template/email.pm send_...

[freeside.git] / FS / FS / Record.pm

diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm
index 7ec8117..f4bf2a2 100644 (file)
--- a/FS/FS/Record.pm
+++ b/FS/FS/Record.pm
@@ -2,9 +2,11 @@ package FS::Record;
 use base qw( Exporter );
 
 use strict;
 use base qw( Exporter );
 
 use strict;

+use charnames ':full';

 use vars qw( $AUTOLOAD
              %virtual_fields_cache %fk_method_cache $fk_table_cache
 use vars qw( $AUTOLOAD
              %virtual_fields_cache %fk_method_cache $fk_table_cache

-             $money_char $lat_lower $lon_upper
+             %virtual_fields_hash_cache $money_char $lat_lower $lon_upper
+             $use_placeholders

            );
 use Carp qw(carp cluck croak confess);
 use Scalar::Util qw( blessed );
            );
 use Carp qw(carp cluck croak confess);
 use Scalar::Util qw( blessed );


@@ -16,12 +18,14 @@ use DBIx::DBSchema 0.43; #0.43 for foreign keys
 use Locale::Country;
 use Locale::Currency;
 use NetAddr::IP; # for validation
 use Locale::Country;
 use Locale::Currency;
 use NetAddr::IP; # for validation

+use Crypt::OpenSSL::RSA;

 use FS::UID qw(dbh datasrc driver_name);
 use FS::CurrentUser;
 use FS::Schema qw(dbdef);
 use FS::SearchCache;
 use FS::Msgcat qw(gettext);
 #use FS::Conf; #dependency loop bs, in install_callback below instead
 use FS::UID qw(dbh datasrc driver_name);
 use FS::CurrentUser;
 use FS::Schema qw(dbdef);
 use FS::SearchCache;
 use FS::Msgcat qw(gettext);
 #use FS::Conf; #dependency loop bs, in install_callback below instead

+use Email::Valid;

 
 use FS::part_virtual_field;
 
 
 use FS::part_virtual_field;
 


@@ -40,6 +44,8 @@ our @EXPORT_OK = qw(
 our $DEBUG = 0;
 our $me = '[FS::Record]';
 
 our $DEBUG = 0;
 our $me = '[FS::Record]';
 

+$use_placeholders = 0;
+

 our $nowarn_identical = 0;
 our $nowarn_classload = 0;
 our $no_update_diff = 0;
 our $nowarn_identical = 0;
 our $nowarn_classload = 0;
 our $no_update_diff = 0;


@@ -49,8 +55,6 @@ our $qsearch_qualify_columns = 1;
 
 our $no_check_foreign = 1; #well, not inefficiently in perl by default anymore
 
 
 our $no_check_foreign = 1; #well, not inefficiently in perl by default anymore
 

-my $rsa_module;
-my $rsa_loaded;

 my $rsa_encrypt;
 my $rsa_decrypt;
 
 my $rsa_encrypt;
 my $rsa_decrypt;
 


@@ -63,7 +67,7 @@ FS::UID->install_callback( sub {
 
   eval "use FS::Conf;";
   die $@ if $@;
 
   eval "use FS::Conf;";
   die $@ if $@;

-  $conf = FS::Conf->new; 
+  $conf = FS::Conf->new;

   $conf_encryption           = $conf->exists('encryption');
   $conf_encryptionmodule     = $conf->config('encryptionmodule');
   $conf_encryptionpublickey  = join("\n",$conf->config('encryptionpublickey'));
   $conf_encryption           = $conf->exists('encryption');
   $conf_encryptionmodule     = $conf->config('encryptionmodule');
   $conf_encryptionpublickey  = join("\n",$conf->config('encryptionpublickey'));


@@ -100,7 +104,7 @@ FS::Record - Database record objects
 
     $record  = qsearchs FS::Record 'table', \%hash;
     $record  = qsearchs FS::Record 'table', { 'column' => 'value', ... };
 
     $record  = qsearchs FS::Record 'table', \%hash;
     $record  = qsearchs FS::Record 'table', { 'column' => 'value', ... };

-    @records = qsearch  FS::Record 'table', \%hash; 
+    @records = qsearch  FS::Record 'table', \%hash;

     @records = qsearch  FS::Record 'table', { 'column' => 'value', ... };
 
     $table = $record->table;
     @records = qsearch  FS::Record 'table', { 'column' => 'value', ... };
 
     $table = $record->table;


@@ -170,14 +174,14 @@ Creates a new record.  It doesn't store it in the database, though.  See
 L<"insert"> for that.
 
 Note that the object stores this hash reference, not a distinct copy of the
 L<"insert"> for that.
 
 Note that the object stores this hash reference, not a distinct copy of the

-hash it points to.  You can ask the object for a copy with the I<hash> 
+hash it points to.  You can ask the object for a copy with the I<hash>

 method.
 
 TABLE can only be omitted when a dervived class overrides the table method.
 
 =cut
 
 method.
 
 TABLE can only be omitted when a dervived class overrides the table method.
 
 =cut
 

-sub new { 
+sub new {

   my $proto = shift;
   my $class = ref($proto) || $proto;
   my $self = {};
   my $proto = shift;
   my $class = ref($proto) || $proto;
   my $self = {};


@@ -188,10 +192,10 @@ sub new {
     carp "warning: FS::Record::new called with table name ". $self->{'Table'}
       unless $nowarn_classload;
   }
     carp "warning: FS::Record::new called with table name ". $self->{'Table'}
       unless $nowarn_classload;
   }

-  
+

   $self->{'Hash'} = shift;
 
   $self->{'Hash'} = shift;
 

-  foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) { 
+  foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {

     $self->{'Hash'}{$field}='';
   }
 
     $self->{'Hash'}{$field}='';
   }
 


@@ -283,6 +287,11 @@ the individual PARAMS_HASHREF queries
 #regular FS::TABLE methods
 #on it.
 
 #regular FS::TABLE methods
 #on it.
 

+C<$FS::Record::qsearch_qualify_columns> package global is enabled by default.
+When enabled, the WHERE clause generated from the 'hashref' parameter has
+the table name prepended to each column name. WHERE column = 'value' becomes
+WHERE table.coumn = 'value'
+

 =cut
 
 my %TYPE = (); #for debugging
 =cut
 
 my %TYPE = (); #for debugging


@@ -485,6 +494,26 @@ sub qsearch {
     croak $error;
   }
 
     croak $error;
   }
 

+
+  # Determine how to format rows returned form a union query:
+  #
+  # * When all queries involved in the union are from the same table:
+  #   Return an array of FS::$table_name objects
+  #
+  # * When union query is performed on multiple tables,
+  #   Return an array of FS::Record objects
+  #   ! Note:  As far as I can tell, this functionality was broken, and
+  #   !        actually results in a crash.  Behavior is left intact
+  #   !        as-is, in case the results are in use somewhere
+  #
+  # * Union query is performed on multiple table,
+  #       and $union_options{classname_from_column} = 1
+  #   Return an array of FS::$classname objects, where $classname is
+  #   derived for each row from a static field inserted each returned
+  #   row of data.
+  #   e.g.: SELECT custnum,first,last,'cust_main' AS `__classname`'.
+
+

   my $table = $stable[0];
   my $pkey = '';
   $table = '' if grep { $_ ne $table } @stable;
   my $table = $stable[0];
   my $pkey = '';
   $table = '' if grep { $_ ne $table } @stable;


@@ -504,7 +533,21 @@ sub qsearch {
   #below was refactored out to _from_hashref, this should use it at some point
 
   my @return;
   #below was refactored out to _from_hashref, this should use it at some point
 
   my @return;

-  if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
+  if ($union_options{classname_from_column}) {
+
+    # todo
+    # I'm not implementing the cache for this use case, at least not yet
+    # -mjackson
+
+    for my $row (@stuff) {
+      my $table_class = $row->{__classname}
+        or die "`__classname` column must be set when ".
+               "using \$union_options{classname_from_column}";
+      push @return, new("FS::$table_class",$row);
+    }
+
+  }
+  elsif ( eval 'scalar(@FS::'. $table. '::ISA);' ) {

     if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
       #derivied class didn't override new method, so this optimization is safe
       if ( $cache ) {
     if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
       #derivied class didn't override new method, so this optimization is safe
       if ( $cache ) {


@@ -527,12 +570,12 @@ sub qsearch {
     # Check for encrypted fields and decrypt them.
    ## only in the local copy, not the cached object
     no warnings 'deprecated'; # XXX silence the warning for now
     # Check for encrypted fields and decrypt them.
    ## only in the local copy, not the cached object
     no warnings 'deprecated'; # XXX silence the warning for now

-    if ( $conf_encryption 
+    if ( $conf_encryption

          && eval '@FS::'. $table . '::encrypted_fields' ) {
       foreach my $record (@return) {
         foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
          && eval '@FS::'. $table . '::encrypted_fields' ) {
       foreach my $record (@return) {
         foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {

-          next if $field eq 'payinfo' 
-                    && ($record->isa('FS::payinfo_transaction_Mixin') 
+          next if $field eq 'payinfo'
+                    && ($record->isa('FS::payinfo_transaction_Mixin')

                         || $record->isa('FS::payinfo_Mixin') )
                     && $record->payby
                     && !grep { $record->payby eq $_ } @encrypt_payby;
                         || $record->isa('FS::payinfo_Mixin') )
                     && $record->payby
                     && !grep { $record->payby eq $_ } @encrypt_payby;


@@ -653,7 +696,7 @@ sub _query {
     push @statement, $statement;
 
     warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
     push @statement, $statement;
 
     warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;

- 
+

 
     foreach my $field (
       grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
 
     foreach my $field (
       grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields


@@ -736,12 +779,12 @@ sub _from_hashref {
 
     # Check for encrypted fields and decrypt them.
    ## only in the local copy, not the cached object
 
     # Check for encrypted fields and decrypt them.
    ## only in the local copy, not the cached object

-    if ( $conf_encryption 
+    if ( $conf_encryption

          && eval '@FS::'. $table . '::encrypted_fields' ) {
       foreach my $record (@return) {
         foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
          && eval '@FS::'. $table . '::encrypted_fields' ) {
       foreach my $record (@return) {
         foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {

-          next if $field eq 'payinfo' 
-                    && ($record->isa('FS::payinfo_transaction_Mixin') 
+          next if $field eq 'payinfo'
+                    && ($record->isa('FS::payinfo_transaction_Mixin')

                         || $record->isa('FS::payinfo_Mixin') )
                     && $record->payby
                     && !grep { $record->payby eq $_ } @encrypt_payby;
                         || $record->isa('FS::payinfo_Mixin') )
                     && $record->payby
                     && !grep { $record->payby eq $_ } @encrypt_payby;


@@ -768,7 +811,7 @@ sub get_real_fields {
   $alias_main ||= $table;
 
   ## could be optimized more for readability
   $alias_main ||= $table;
 
   ## could be optimized more for readability

-  return ( 
+  return (

     map {
 
       my $op = '=';
     map {
 
       my $op = '=';


@@ -829,7 +872,7 @@ sub get_real_fields {
       }
 
     } @{ $real_fields }
       }
 
     } @{ $real_fields }

-  );  
+  );

 }
 
 =item by_key PRIMARY_KEY_VALUE
 }
 
 =item by_key PRIMARY_KEY_VALUE


@@ -867,7 +910,7 @@ single SELECT spanning multiple tables, and cache the results for subsequent
 method calls.  Interface will almost definately change in an incompatible
 fashion.
 
 method calls.  Interface will almost definately change in an incompatible
 fashion.
 

-Arguments: 
+Arguments:

 
 =cut
 
 
 =cut
 


@@ -951,7 +994,7 @@ sub get {
   # to avoid "Use of unitialized value" errors
   if ( defined ( $self->{Hash}->{$field} ) ) {
     $self->{Hash}->{$field};
   # to avoid "Use of unitialized value" errors
   if ( defined ( $self->{Hash}->{$field} ) ) {
     $self->{Hash}->{$field};

-  } else { 
+  } else {

     '';
   }
 }
     '';
   }
 }


@@ -966,7 +1009,7 @@ Sets the value of the column/field/key COLUMN to VALUE.  Returns VALUE.
 
 =cut
 
 
 =cut
 

-sub set { 
+sub set {

   my($self,$field,$value) = @_;
   $self->{'modified'} = 1;
   $self->{'Hash'}->{$field} = $value;
   my($self,$field,$value) = @_;
   $self->{'modified'} = 1;
   $self->{'Hash'}->{$field} = $value;


@@ -1025,7 +1068,7 @@ sub AUTOLOAD {
     my %search = ( $foreign_column => $pkey_value );
 
     # FS::Record->$method() ?  they're actually just subs :/
     my %search = ( $foreign_column => $pkey_value );
 
     # FS::Record->$method() ?  they're actually just subs :/

-    if ( $method eq 'qsearchs' ) { 
+    if ( $method eq 'qsearchs' ) {

       return $pkey_value ? qsearchs( $table, \%search ) : '';
     } elsif ( $method eq 'qsearch' ) {
       return $pkey_value ? qsearch(  $table, \%search ) : ();
       return $pkey_value ? qsearchs( $table, \%search ) : '';
     } elsif ( $method eq 'qsearch' ) {
       return $pkey_value ? qsearch(  $table, \%search ) : ();


@@ -1039,7 +1082,7 @@ sub AUTOLOAD {
     $self->setfield($field,$value);
   } else {
     $self->getfield($field);
     $self->setfield($field,$value);
   } else {
     $self->getfield($field);

-  }    
+  }

 }
 
 # efficient (also, old, doesn't support FK stuff)
 }
 
 # efficient (also, old, doesn't support FK stuff)


@@ -1050,7 +1093,7 @@ sub AUTOLOAD {
 #    $_[0]->setfield($field, $_[1]);
 #  } else {
 #    $_[0]->getfield($field);
 #    $_[0]->setfield($field, $_[1]);
 #  } else {
 #    $_[0]->getfield($field);

-#  }    
+#  }

 #}
 
 # get_fk_method(TABLE, FIELD)
 #}
 
 # get_fk_method(TABLE, FIELD)


@@ -1171,7 +1214,7 @@ sub hash {
   my($self) = @_;
   confess $self. ' -> hash: Hash attribute is undefined'
     unless defined($self->{'Hash'});
   my($self) = @_;
   confess $self. ' -> hash: Hash attribute is undefined'
     unless defined($self->{'Hash'});

-  %{ $self->{'Hash'} }; 
+  %{ $self->{'Hash'} };

 }
 
 =item hashref
 }
 
 =item hashref


@@ -1327,14 +1370,14 @@ sub insert {
   }
 
   my $table = $self->table;
   }
 
   my $table = $self->table;

-  
+

   # Encrypt before the database
   if (    scalar( eval '@FS::'. $table . '::encrypted_fields')
        && $conf_encryption
   ) {
     foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
   # Encrypt before the database
   if (    scalar( eval '@FS::'. $table . '::encrypted_fields')
        && $conf_encryption
   ) {
     foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {

-      next if $field eq 'payinfo' 
-                && ($self->isa('FS::payinfo_transaction_Mixin') 
+      next if $field eq 'payinfo'
+                && ($self->isa('FS::payinfo_transaction_Mixin')

                     || $self->isa('FS::payinfo_Mixin') )
                 && $self->payby
                 && !grep { $self->payby eq $_ } @encrypt_payby;
                     || $self->isa('FS::payinfo_Mixin') )
                 && $self->payby
                 && !grep { $self->payby eq $_ } @encrypt_payby;


@@ -1348,37 +1391,60 @@ sub insert {
     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
     real_fields($table)
   ;
     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
     real_fields($table)
   ;

-  my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
-  #eslaf

 
   my $statement = "INSERT INTO $table ";
 
   my $statement = "INSERT INTO $table ";

-  if ( @real_fields ) {
-    $statement .=
-      "( ".
-        join( ', ', @real_fields ).
-      ") VALUES (".
-        join( ', ', @values ).
-       ")"
-    ;
-  } else {
+  my @bind_values = ();
+
+  if ( ! @real_fields ) {
+

     $statement .= 'DEFAULT VALUES';
     $statement .= 'DEFAULT VALUES';

+
+  } else {
+
+    if ( $use_placeholders ) {
+
+      @bind_values = map $self->getfield($_), @real_fields;
+
+      $statement .=
+        "( ".
+          join( ', ', @real_fields ).
+        ") VALUES (".
+          join( ', ', map '?', @real_fields ). # @bind_values ).
+         ")"
+      ;
+
+    } else {
+
+      my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
+
+      $statement .=
+        "( ".
+          join( ', ', @real_fields ).
+        ") VALUES (".
+          join( ', ', @values ).
+         ")"
+      ;
+
+   }
+

   }
   }

+

   warn "[debug]$me $statement\n" if $DEBUG > 1;
   my $sth = dbh->prepare($statement) or return dbh->errstr;
 
   local $SIG{HUP} = 'IGNORE';
   local $SIG{INT} = 'IGNORE';
   warn "[debug]$me $statement\n" if $DEBUG > 1;
   my $sth = dbh->prepare($statement) or return dbh->errstr;
 
   local $SIG{HUP} = 'IGNORE';
   local $SIG{INT} = 'IGNORE';

-  local $SIG{QUIT} = 'IGNORE'; 
+  local $SIG{QUIT} = 'IGNORE';

   local $SIG{TERM} = 'IGNORE';
   local $SIG{TSTP} = 'IGNORE';
   local $SIG{PIPE} = 'IGNORE';
 
   local $SIG{TERM} = 'IGNORE';
   local $SIG{TSTP} = 'IGNORE';
   local $SIG{PIPE} = 'IGNORE';
 

-  $sth->execute or return $sth->errstr;
+  $sth->execute(@bind_values) or return $sth->errstr;

 
   # get inserted id from the database, if applicable & needed
   if ( $db_seq && ! $self->getfield($primary_key) ) {
     warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
 
   # get inserted id from the database, if applicable & needed
   if ( $db_seq && ! $self->getfield($primary_key) ) {
     warn "[debug]$me retreiving sequence from database\n" if $DEBUG;

-  
+

     my $insertid = '';
 
     if ( driver_name eq 'Pg' ) {
     my $insertid = '';
 
     if ( driver_name eq 'Pg' ) {


@@ -1427,7 +1493,7 @@ sub insert {
     } else {
 
       dbh->rollback if $FS::UID::AutoCommit;
     } else {
 
       dbh->rollback if $FS::UID::AutoCommit;

-      return "don't know how to retreive inserted ids from ". driver_name. 
+      return "don't know how to retreive inserted ids from ". driver_name.

              ", try using counterfiles (maybe run dbdef-create?)";
 
     }
              ", try using counterfiles (maybe run dbdef-create?)";
 
     }


@@ -1451,7 +1517,7 @@ sub insert {
 
   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
 
 
   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
 

-  # Now that it has been saved, reset the encrypted fields so that $new 
+  # Now that it has been saved, reset the encrypted fields so that $new

   # can still be used.
   foreach my $field (keys %{$saved}) {
     $self->setfield($field, $saved->{$field});
   # can still be used.
   foreach my $field (keys %{$saved}) {
     $self->setfield($field, $saved->{$field});


@@ -1510,7 +1576,7 @@ sub delete {
 
   local $SIG{HUP} = 'IGNORE';
   local $SIG{INT} = 'IGNORE';
 
   local $SIG{HUP} = 'IGNORE';
   local $SIG{INT} = 'IGNORE';

-  local $SIG{QUIT} = 'IGNORE'; 
+  local $SIG{QUIT} = 'IGNORE';

   local $SIG{TERM} = 'IGNORE';
   local $SIG{TSTP} = 'IGNORE';
   local $SIG{PIPE} = 'IGNORE';
   local $SIG{TERM} = 'IGNORE';
   local $SIG{TSTP} = 'IGNORE';
   local $SIG{PIPE} = 'IGNORE';


@@ -1518,7 +1584,7 @@ sub delete {
   my $rc = $sth->execute or return $sth->errstr;
   #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
   $h_sth->execute or return $h_sth->errstr if $h_sth;
   my $rc = $sth->execute or return $sth->errstr;
   #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
   $h_sth->execute or return $h_sth->errstr if $h_sth;

-  
+

   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
 
   #no need to needlessly destoy the data either (causes problems actually)
   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
 
   #no need to needlessly destoy the data either (causes problems actually)


@@ -1568,15 +1634,15 @@ sub replace {
 
   my $error = $new->check;
   return $error if $error;
 
   my $error = $new->check;
   return $error if $error;

-  
+

   # Encrypt for replace
   my $saved = {};
   if (    scalar( eval '@FS::'. $new->table . '::encrypted_fields')
        && $conf_encryption
   ) {
     foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
   # Encrypt for replace
   my $saved = {};
   if (    scalar( eval '@FS::'. $new->table . '::encrypted_fields')
        && $conf_encryption
   ) {
     foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {

-      next if $field eq 'payinfo' 
-                && ($new->isa('FS::payinfo_transaction_Mixin') 
+      next if $field eq 'payinfo'
+                && ($new->isa('FS::payinfo_transaction_Mixin')

                     || $new->isa('FS::payinfo_Mixin') )
                 && $new->payby
                 && !grep { $new->payby eq $_ } @encrypt_payby;
                     || $new->isa('FS::payinfo_Mixin') )
                 && $new->payby
                 && !grep { $new->payby eq $_ } @encrypt_payby;


@@ -1588,7 +1654,7 @@ sub replace {
   #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
   my %diff = map { ($new->getfield($_) ne $old->getfield($_))
                    ? ($_, $new->getfield($_)) : () } $old->fields;
   #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
   my %diff = map { ($new->getfield($_) ne $old->getfield($_))
                    ? ($_, $new->getfield($_)) : () } $old->fields;

-                   
+

   unless (keys(%diff) || $no_update_diff ) {
     carp "[warning]$me ". ref($new)."->replace ".
            ( $primary_key ? "$primary_key ".$new->get($primary_key) : '' ).
   unless (keys(%diff) || $no_update_diff ) {
     carp "[warning]$me ". ref($new)."->replace ".
            ( $primary_key ? "$primary_key ".$new->get($primary_key) : '' ).


@@ -1599,7 +1665,7 @@ sub replace {
 
   my $statement = "UPDATE ". $old->table. " SET ". join(', ',
     map {
 
   my $statement = "UPDATE ". $old->table. " SET ". join(', ',
     map {

-      "$_ = ". _quote($new->getfield($_),$old->table,$_) 
+      "$_ = ". _quote($new->getfield($_),$old->table,$_)

     } real_fields($old->table)
   ). ' WHERE '.
     join(' AND ',
     } real_fields($old->table)
   ). ' WHERE '.
     join(' AND ',


@@ -1649,7 +1715,7 @@ sub replace {
 
   local $SIG{HUP} = 'IGNORE';
   local $SIG{INT} = 'IGNORE';
 
   local $SIG{HUP} = 'IGNORE';
   local $SIG{INT} = 'IGNORE';

-  local $SIG{QUIT} = 'IGNORE'; 
+  local $SIG{QUIT} = 'IGNORE';

   local $SIG{TERM} = 'IGNORE';
   local $SIG{TSTP} = 'IGNORE';
   local $SIG{PIPE} = 'IGNORE';
   local $SIG{TERM} = 'IGNORE';
   local $SIG{TSTP} = 'IGNORE';
   local $SIG{PIPE} = 'IGNORE';


@@ -1661,7 +1727,7 @@ sub replace {
 
   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
 
 
   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
 

-  # Now that it has been saved, reset the encrypted fields so that $new 
+  # Now that it has been saved, reset the encrypted fields so that $new

   # can still be used.
   foreach my $field (keys %{$saved}) {
     $new->setfield($field, $saved->{$field});
   # can still be used.
   foreach my $field (keys %{$saved}) {
     $new->setfield($field, $saved->{$field});


@@ -1705,7 +1771,7 @@ non-custom fields, etc., and call this method via $self->SUPER::check.
 
 =cut
 
 
 =cut
 

-sub check { 
+sub check {

     my $self = shift;
     foreach my $field ($self->virtual_fields) {
         my $error = $self->ut_textn($field);
     my $self = shift;
     foreach my $field ($self->virtual_fields) {
         my $error = $self->ut_textn($field);


@@ -1716,7 +1782,7 @@ sub check {
 
 =item virtual_fields [ TABLE ]
 
 
 =item virtual_fields [ TABLE ]
 

-Returns a list of virtual fields defined for the table.  This should not 
+Returns a list of virtual fields defined for the table.  This should not

 be exported, and should only be called as an instance or class method.
 
 =cut
 be exported, and should only be called as an instance or class method.
 
 =cut


@@ -1745,6 +1811,41 @@ sub virtual_fields {
 
 }
 
 
 }
 

+=item virtual_fields_hash [ TABLE ]
+
+Returns a list of virtual field records as a hash defined for the table.  This should not
+be exported, and should only be called as an instance or class method.
+
+=cut
+
+sub virtual_fields_hash {
+  my $self = shift;
+  my $table;
+  $table = $self->table or confess "virtual_fields called on non-table";
+
+  confess "Unknown table $table" unless dbdef->table($table);
+
+  return () unless dbdef->table('part_virtual_field');
+
+  unless ( $virtual_fields_hash_cache{$table} ) {
+    $virtual_fields_hash_cache{$table} = [];
+    my $concat = [ "'cf_'", "name" ];
+    my $select = concat_sql($concat).' as name, label, length';
+    my @vfields = qsearch({
+      select => $select,
+      table => 'part_virtual_field',
+      hashref => { 'dbtable' => $table, },
+    });
+
+    foreach (@vfields) {
+      push @{ $virtual_fields_hash_cache{$table} }, $_->{Hash};
+    }
+  }
+
+  @{$virtual_fields_hash_cache{$table}};
+
+}
+

 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
 
 Processes a batch import as a queued JSRPC job
 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
 
 Processes a batch import as a queued JSRPC job


@@ -1810,8 +1911,8 @@ format_types).
 
 =back
 
 
 =back
 

-PARAMS is a hashref (or base64-encoded Storable hashref) containing the 
-POSTed data.  It must contain the field "uploaded files", generated by 
+PARAMS is a hashref (or base64-encoded Storable hashref) containing the
+POSTed data.  It must contain the field "uploaded files", generated by

 /elements/file-upload.html and containing the list of uploaded files.
 Currently only supports a single file named "file".
 
 /elements/file-upload.html and containing the list of uploaded files.
 Currently only supports a single file named "file".
 


@@ -1826,7 +1927,7 @@ sub process_batch_import {
   my %formats = %{ $opt->{formats} };
 
   warn Dumper($param) if $DEBUG;
   my %formats = %{ $opt->{formats} };
 
   warn Dumper($param) if $DEBUG;

-  
+

   my $files = $param->{'uploaded_files'}
     or die "No files provided.\n";
 
   my $files = $param->{'uploaded_files'}
     or die "No files provided.\n";
 


@@ -2166,7 +2267,7 @@ sub batch_import {
       next if $line =~ /^\s*$/; #skip empty lines
 
       $line = &{$row_callback}($line) if $row_callback;
       next if $line =~ /^\s*$/; #skip empty lines
 
       $line = &{$row_callback}($line) if $row_callback;

-      
+

       next if $line =~ /^\s*$/; #skip empty lines
 
       $parser->parse($line) or do {
       next if $line =~ /^\s*$/; #skip empty lines
 
       $parser->parse($line) or do {


@@ -2219,7 +2320,7 @@ sub batch_import {
     foreach my $field ( @fields ) {
 
       my $value = shift @columns;
     foreach my $field ( @fields ) {
 
       my $value = shift @columns;

-     
+

       if ( ref($field) eq 'CODE' ) {
         #&{$field}(\%hash, $value);
         push @later, $field, $value;
       if ( ref($field) eq 'CODE' ) {
         #&{$field}(\%hash, $value);
         push @later, $field, $value;


@@ -2344,7 +2445,7 @@ sub _h_statement {
 
 =item unique COLUMN
 
 
 =item unique COLUMN
 

-B<Warning>: External use is B<deprecated>.  
+B<Warning>: External use is B<deprecated>.

 
 Replaces COLUMN in record with a unique number, using counters in the
 filesystem.  Used by the B<insert> method on single-field unique columns
 
 Replaces COLUMN in record with a unique number, using counters in the
 filesystem.  Used by the B<insert> method on single-field unique columns


@@ -2515,7 +2616,7 @@ sub ut_numbern {
 
 =item ut_decimal COLUMN[, DIGITS]
 
 
 =item ut_decimal COLUMN[, DIGITS]
 

-Check/untaint decimal numbers (up to DIGITS decimal places.  If there is an 
+Check/untaint decimal numbers (up to DIGITS decimal places.  If there is an

 error, returns the error, otherwise returns false.
 
 =item ut_decimaln COLUMN[, DIGITS]
 error, returns the error, otherwise returns false.
 
 =item ut_decimaln COLUMN[, DIGITS]


@@ -2620,7 +2721,7 @@ sub ut_currency {
 =item ut_text COLUMN
 
 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
 =item ut_text COLUMN
 
 Check/untaint text.  Alphanumerics, spaces, and the following punctuation

-symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
+symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < > ~

 May not be null.  If there is an error, returns the error, otherwise returns
 false.
 
 May not be null.  If there is an error, returns the error, otherwise returns
 false.
 


@@ -2634,7 +2735,7 @@ sub ut_text {
   # \p{Word} = alphanumerics, marks (diacritics), and connectors
   # see perldoc perluniprops
   $self->getfield($field)
   # \p{Word} = alphanumerics, marks (diacritics), and connectors
   # see perldoc perluniprops
   $self->getfield($field)

-    =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/
+    =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>\~$money_char]+)$/

       or return gettext('illegal_or_empty_text'). " $field: ".
                  $self->getfield($field);
   $self->setfield($field,$1);
       or return gettext('illegal_or_empty_text'). " $field: ".
                  $self->getfield($field);
   $self->setfield($field,$1);


@@ -2680,7 +2781,7 @@ error, returns the error, otherwise returns false.
 
 sub ut_alphan {
   my($self,$field)=@_;
 
 sub ut_alphan {
   my($self,$field)=@_;

-  $self->getfield($field) =~ /^(\w*)$/ 
+  $self->getfield($field) =~ /^(\w*)$/

     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
   $self->setfield($field,$1);
   '';
     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
   $self->setfield($field,$1);
   '';


@@ -2695,7 +2796,7 @@ an error, returns the error, otherwise returns false.
 
 sub ut_alphasn {
   my($self,$field)=@_;
 
 sub ut_alphasn {
   my($self,$field)=@_;

-  $self->getfield($field) =~ /^([\w ]*)$/ 
+  $self->getfield($field) =~ /^([\w ]*)$/

     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
   $self->setfield($field,$1);
   '';
     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
   $self->setfield($field,$1);
   '';


@@ -2821,11 +2922,9 @@ to 127.0.0.1.
 sub ut_ip {
   my( $self, $field ) = @_;
   $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
 sub ut_ip {
   my( $self, $field ) = @_;
   $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';

-  $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
-    or return "Illegal (IP address) $field: ". $self->getfield($field);
-  for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
-  $self->setfield($field, "$1.$2.$3.$4");
-  '';
+  return "Illegal (IP address) $field: ".$self->getfield($field)
+    unless $self->getfield($field) =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/;
+  $self->ut_ip46($field);

 }
 
 =item ut_ipn COLUMN
 }
 
 =item ut_ipn COLUMN


@@ -2853,8 +2952,9 @@ Check/untaint IPv4 or IPv6 address.
 
 sub ut_ip46 {
   my( $self, $field ) = @_;
 
 sub ut_ip46 {
   my( $self, $field ) = @_;

-  my $ip = NetAddr::IP->new($self->getfield($field))
-    or return "Illegal (IP address) $field: ".$self->getfield($field);
+  my $ip = NetAddr::IP->new(
+    $self->_ut_ip_strip_leading_zeros( $self->getfield( $field ) )
+  ) or return "Illegal (IP address) $field: ".$self->getfield($field);

   $self->setfield($field, lc($ip->addr));
   return '';
 }
   $self->setfield($field, lc($ip->addr));
   return '';
 }


@@ -2874,6 +2974,21 @@ sub ut_ip46n {
   $self->ut_ip46($field);
 }
 
   $self->ut_ip46($field);
 }
 

+sub _ut_ip_strip_leading_zeros {
+  # strip user-entered leading 0's from IP addresses
+  # so parsers like NetAddr::IP don't mangle the address
+  # e.g. NetAddr::IP converts 10.0.022.220 into 10.0.18.220
+
+  my ( $self, $ip ) = @_;
+
+  return join '.', map int, split /\./, $ip
+    if $ip
+    && $ip =~ /\./
+    && $ip =~ /[\.^]0/;
+  $ip;
+}
+
+

 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
 
 Check/untaint coordinates.
 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
 
 Check/untaint coordinates.


@@ -2913,6 +3028,10 @@ sub ut_coord {
   my $coord = $self->getfield($field);
   my $neg = $coord =~ s/^(-)//;
 
   my $coord = $self->getfield($field);
   my $neg = $coord =~ s/^(-)//;
 

+  # ignore degree symbol at the end,
+  #   but not otherwise supporting degree/minutes/seconds symbols
+  $coord =~ s/\N{DEGREE SIGN}\s*$//;
+

   my ($d, $m, $s) = (0, 0, 0);
 
   if (
   my ($d, $m, $s) = (0, 0, 0);
 
   if (


@@ -3010,8 +3129,8 @@ sub ut_name {
   $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/
     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
   my $name = $1;
   $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/
     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
   my $name = $1;

-  $name =~ s/^\s+//; 
-  $name =~ s/\s+$//; 
+  $name =~ s/^\s+//;
+  $name =~ s/\s+$//;

   $name =~ s/\s+/ /g;
   $self->setfield($field, $name);
   '';
   $name =~ s/\s+/ /g;
   $self->setfield($field, $name);
   '';


@@ -3057,6 +3176,13 @@ sub ut_zip {
                 $self->getfield($field);
     $self->setfield($field, "$1 $2");
 
                 $self->getfield($field);
     $self->setfield($field, "$1 $2");
 

+  } elsif ( $country eq 'AU' ) {
+
+    $self->getfield($field) =~ /^\s*(\d{4})\s*$/
+      or return gettext('illegal_zip'). " $field for country $country: ".
+                $self->getfield($field);
+    $self->setfield($field, $1);
+

   } else {
 
     if ( $self->getfield($field) =~ /^\s*$/
   } else {
 
     if ( $self->getfield($field) =~ /^\s*$/


@@ -3085,7 +3211,7 @@ see L<Locale::Country>.
 sub ut_country {
   my( $self, $field ) = @_;
   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
 sub ut_country {
   my( $self, $field ) = @_;
   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {

-    if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/ 
+    if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/

          && country2code($1) ) {
       $self->setfield($field,uc(country2code($1)));
     }
          && country2code($1) ) {
       $self->setfield($field,uc(country2code($1)));
     }


@@ -3140,6 +3266,60 @@ sub ut_enumn {
     : '';
 }
 
     : '';
 }
 

+=item ut_date COLUMN
+
+Check/untaint a column containing a date string.
+
+Date will be normalized to YYYY-MM-DD format
+
+=cut
+
+sub ut_date {
+  my ( $self, $field ) = @_;
+  my $value = $self->getfield( $field );
+
+  my @date = split /[\-\/]/, $value;
+  if ( scalar(@date) == 3 ) {
+    @date = @date[2,0,1] if $date[2] >= 1900;
+
+    local $@;
+    my $ymd;
+    eval {
+      # DateTime will die given invalid date
+      $ymd = DateTime->new(
+        year  => $date[0],
+        month => $date[1],
+        day   => $date[2],
+      )->ymd('-');
+    };
+
+    unless( $@ ) {
+      $self->setfield( $field, $ymd ) unless $value eq $ymd;
+      return '';
+    }
+
+  }
+  return "Illegal (date) field $field: $value";
+}
+
+=item ut_daten COLUMN
+
+Check/untaint a column containing a date string.
+
+Column may be null.
+
+Date will be normalized to YYYY-MM-DD format
+
+=cut
+
+sub ut_daten {
+  my ( $self, $field ) = @_;
+
+  $self->getfield( $field ) =~ /^()$/
+  ? $self->setfield( $field, '' )
+  : $self->ut_date( $field );
+}
+

 =item ut_flag COLUMN
 
 Check/untaint a column if it contains either an empty string or 'Y'.  This
 =item ut_flag COLUMN
 
 Check/untaint a column if it contains either an empty string or 'Y'.  This


@@ -3220,6 +3400,36 @@ sub ut_agentnum_acl {
 
 }
 
 
 }
 

+
+=item ut_email COLUMN
+
+Check column contains a valid E-Mail address
+
+=cut
+
+sub ut_email {
+  my ( $self, $field ) = @_;
+  Email::Valid->address( $self->getfield( $field ) )
+    ? ''
+    : "Illegal (email) field $field: ". $self->getfield( $field );
+}
+
+=item ut_emailn COLUMN
+
+Check column contains a valid E-Mail address
+
+May be null
+
+=cut
+
+sub ut_emailn {
+  my ( $self, $field ) = @_;
+
+  $self->getfield( $field ) =~ /^$/
+    ? $self->getfield( $field, '' )
+    : $self->ut_email( $field );
+}
+

 =item trim_whitespace FIELD[, FIELD ... ]
 
 Strip leading and trailing spaces from the value in the named FIELD(s).
 =item trim_whitespace FIELD[, FIELD ... ]
 
 Strip leading and trailing spaces from the value in the named FIELD(s).


@@ -3325,27 +3535,19 @@ sub decrypt {
 }
 
 sub loadRSA {
 }
 
 sub loadRSA {

-    my $self = shift;
-    #Initialize the Module
-    $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
+  my $self = shift;

 
 

-    if ($conf_encryptionmodule && $conf_encryptionmodule ne '') {
-      $rsa_module = $conf_encryptionmodule;
-    }
+  my $rsa_module = $conf_encryptionmodule || 'Crypt::OpenSSL::RSA';

 
 

-    if (!$rsa_loaded) {
-       eval ("require $rsa_module"); # No need to import the namespace
-       $rsa_loaded++;
-    }
-    # Initialize Encryption
-    if ($conf_encryptionpublickey && $conf_encryptionpublickey ne '') {
-      $rsa_encrypt = $rsa_module->new_public_key($conf_encryptionpublickey);
-    }
+  # Initialize Encryption
+  if ($conf_encryptionpublickey && $conf_encryptionpublickey ne '') {
+    $rsa_encrypt = $rsa_module->new_public_key($conf_encryptionpublickey);
+  }

     
     

-    # Intitalize Decryption
-    if ($conf_encryptionprivatekey && $conf_encryptionprivatekey ne '') {
-      $rsa_decrypt = $rsa_module->new_private_key($conf_encryptionprivatekey);
-    }
+  # Intitalize Decryption
+  if ($conf_encryptionprivatekey && $conf_encryptionprivatekey ne '') {
+    $rsa_decrypt = $rsa_module->new_private_key($conf_encryptionprivatekey);
+  }

 }
 
 =item h_search ACTION
 }
 
 =item h_search ACTION


@@ -3409,8 +3611,8 @@ sub scalar_sql {
 
 =item count [ WHERE [, PLACEHOLDER ...] ]
 
 
 =item count [ WHERE [, PLACEHOLDER ...] ]
 

-Convenience method for the common case of "SELECT COUNT(*) FROM table", 
-with optional WHERE.  Must be called as method on a class with an 
+Convenience method for the common case of "SELECT COUNT(*) FROM table",
+with optional WHERE.  Must be called as method on a class with an

 associated table.
 
 =cut
 associated table.
 
 =cut


@@ -3447,7 +3649,7 @@ sub row_exists {
 
 =item real_fields [ TABLE ]
 
 
 =item real_fields [ TABLE ]
 

-Returns a list of the real columns in the specified table.  Called only by 
+Returns a list of the real columns in the specified table.  Called only by

 fields() and other subroutines elsewhere in FS::Record.
 
 =cut
 fields() and other subroutines elsewhere in FS::Record.
 
 =cut


@@ -3462,7 +3664,7 @@ sub real_fields {
 
 =item pvf FIELD_NAME
 
 
 =item pvf FIELD_NAME
 

-Returns the FS::part_virtual_field object corresponding to a field in the 
+Returns the FS::part_virtual_field object corresponding to a field in the

 record (specified by FIELD_NAME).
 
 =cut
 record (specified by FIELD_NAME).
 
 =cut


@@ -3475,7 +3677,7 @@ sub pvf {
     my $concat = [ "'cf_'", "name" ];
     return qsearchs({   table   =>  'part_virtual_field',
                         hashref =>  { dbtable => $self->table,
     my $concat = [ "'cf_'", "name" ];
     return qsearchs({   table   =>  'part_virtual_field',
                         hashref =>  { dbtable => $self->table,

-                                      name    => $name 
+                                      name    => $name

                                     },
                         select  =>  'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
                     });
                                     },
                         select  =>  'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
                     });


@@ -3509,18 +3711,26 @@ sub _quote {
     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
           "using 0 instead";
     0;
     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
           "using 0 instead";
     0;

-  } elsif ( $value =~ /^\d+(\.\d+)?$/ && 
+  } elsif ( $value =~ /^\d+(\.\d+)?$/ &&

             ! $column_type =~ /(char|binary|text)$/i ) {
     $value;
   } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
            && driver_name eq 'Pg'
           )
   {
             ! $column_type =~ /(char|binary|text)$/i ) {
     $value;
   } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
            && driver_name eq 'Pg'
           )
   {

-    no strict 'subs';
-#    dbh->quote($value, { pg_type => PG_BYTEA() }); # doesn't work right
-    # Pg binary string quoting: convert each character to 3-digit octal prefixed with \\, 
-    # single-quote the whole mess, and put an "E" in front.
-    return ("E'" . join('', map { sprintf('\\\\%03o', ord($_)) } split(//, $value) ) . "'");
+    local $@;
+
+    eval { $value = dbh->quote($value, { pg_type => PG_BYTEA() }); };
+
+    if ( $@ && $@ =~ /Wide character/i ) {
+      warn 'Correcting malformed UTF-8 string for binary quote()'
+        if $DEBUG;
+      utf8::decode($value);
+      utf8::encode($value);
+      $value = dbh->quote($value, { pg_type => PG_BYTEA() });
+    }
+
+    $value;

   } else {
     dbh->quote($value);
   }
   } else {
     dbh->quote($value);
   }


@@ -3577,7 +3787,7 @@ the current database.
 
 =cut
 
 
 =cut
 

-sub str2time_sql { 
+sub str2time_sql {

   my $driver = shift || driver_name;
 
   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;
   my $driver = shift || driver_name;
 
   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;


@@ -3600,7 +3810,7 @@ the current database.
 
 =cut
 
 
 =cut
 

-sub str2time_sql_closing { 
+sub str2time_sql_closing {

   my $driver = shift || driver_name;
 
   return ' )::INTEGER ' if $driver =~ /^Pg/i;
   my $driver = shift || driver_name;
 
   return ' )::INTEGER ' if $driver =~ /^Pg/i;


@@ -3674,7 +3884,7 @@ sub concat_sql {
 
 =item group_concat_sql COLUMN, DELIMITER
 
 
 =item group_concat_sql COLUMN, DELIMITER
 

-Returns an SQL expression to concatenate an aggregate column, using 
+Returns an SQL expression to concatenate an aggregate column, using

 GROUP_CONCAT() for mysql and array_to_string() and array_agg() for Pg.
 
 =cut
 GROUP_CONCAT() for mysql and array_to_string() and array_agg() for Pg.
 
 =cut


@@ -3692,7 +3902,7 @@ sub group_concat_sql {
 
 =item midnight_sql DATE
 
 
 =item midnight_sql DATE
 

-Returns an SQL expression to convert DATE (a unix timestamp) to midnight 
+Returns an SQL expression to convert DATE (a unix timestamp) to midnight

 on that day in the system timezone, using the default driver name.
 
 =cut
 on that day in the system timezone, using the default driver name.
 
 =cut


@@ -3764,4 +3974,3 @@ http://poop.sf.net/
 =cut
 
 1;
 =cut
 
 1;

-