package FS::Record;
use strict;
+use charnames ':full';
use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG
- $conf $conf_encryption $me
%virtual_fields_cache
+ $money_char $lat_lower $lon_upper
+ $me
$nowarn_identical $nowarn_classload
- $no_update_diff $no_check_foreign
+ $no_update_diff $no_history $qsearch_qualify_columns
+ $no_check_foreign
+ @encrypt_payby
);
use Exporter;
use Carp qw(carp cluck croak confess);
use FS::Schema qw(dbdef);
use FS::SearchCache;
use FS::Msgcat qw(gettext);
+use NetAddr::IP; # for validation
+use Data::Dumper;
#use FS::Conf; #dependency loop bs, in install_callback below instead
+use Email::Valid;
use FS::part_virtual_field;
@ISA = qw(Exporter);
+@encrypt_payby = qw( CARD DCRD CHEK DCHK );
+
#export dbdef for now... everything else expects to find it here
-@EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef jsearch
- str2time_sql str2time_sql_closing regexp_sql not_regexp_sql );
+@EXPORT_OK = qw(
+ dbh fields hfields qsearch qsearchs dbdef jsearch
+ str2time_sql str2time_sql_closing regexp_sql not_regexp_sql
+ concat_sql group_concat_sql
+ midnight_sql
+);
$DEBUG = 0;
$me = '[FS::Record]';
$nowarn_identical = 0;
$nowarn_classload = 0;
$no_update_diff = 0;
+$no_history = 0;
+
+$qsearch_qualify_columns = 0;
+
$no_check_foreign = 0;
my $rsa_module;
my $rsa_encrypt;
my $rsa_decrypt;
-$conf = '';
-$conf_encryption = '';
+our $conf = '';
+our $conf_encryption = '';
+our $conf_encryptionmodule = '';
+our $conf_encryptionpublickey = '';
+our $conf_encryptionprivatekey = '';
FS::UID->install_callback( sub {
+
eval "use FS::Conf;";
die $@ if $@;
- $conf = FS::Conf->new;
- $conf_encryption = $conf->exists('encryption');
+ $conf = FS::Conf->new;
+ $conf_encryption = $conf->exists('encryption');
+ $conf_encryptionmodule = $conf->config('encryptionmodule');
+ $conf_encryptionpublickey = join("\n",$conf->config('encryptionpublickey'));
+ $conf_encryptionprivatekey = join("\n",$conf->config('encryptionprivatekey'));
+ $money_char = $conf->config('money_char') || '$';
+ my $nw_coords = $conf->exists('geocode-require_nw_coordinates');
+ $lat_lower = $nw_coords ? 1 : -90;
+ $lon_upper = $nw_coords ? -1 : 180;
+
$File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc;
+
if ( driver_name eq 'Pg' ) {
eval "use DBD::Pg ':pg_types'";
die $@ if $@;
} else {
eval "sub PG_BYTEA { die 'guru meditation #9: calling PG_BYTEA when not running Pg?'; }";
}
+
} );
=head1 NAME
$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;
$error = $record->ut_floatn('column');
$error = $record->ut_number('column');
$error = $record->ut_numbern('column');
+ $error = $record->ut_decimal('column');
+ $error = $record->ut_decimaln('column');
$error = $record->ut_snumber('column');
$error = $record->ut_snumbern('column');
$error = $record->ut_money('column');
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
-sub new {
+sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self = {};
carp "warning: FS::Record::new called with table name ". $self->{'Table'}
unless $nowarn_classload;
}
-
+
$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->{'modified'} = 0;
+ $self->_simplecache($self->{'Hash'}) if $self->can('_simplecache');
$self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
$self;
#regular FS::TABLE methods
#on it.
+C<$FS::Record::qsearch_qualify_columns> package global is disabled 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
my $bind_type = { TYPE => SQL_VARCHAR };
- if ( $type =~ /(big)?(int|serial)/i && $value =~ /^\d+(\.\d+)?$/ ) {
+ if ( $type =~ /(big)?(int|serial)/i && $value =~ /^-?\d+(\.\d+)?$/ ) {
$bind_type = { TYPE => SQL_INTEGER };
my @bind_type = ();
my $dbh = dbh;
foreach my $stable ( @stable ) {
- my $record = shift @record;
+ #stop altering the caller's hashref
+ my $record = { %{ shift(@record) || {} } };#and be liberal in receipt
my $select = shift @select;
my $extra_sql = shift @extra_sql;
my $extra_param = shift @extra_param;
my $pkey = $dbdef_table->primary_key;
my @real_fields = grep exists($record->{$_}), real_fields($table);
- my @virtual_fields;
- if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
- @virtual_fields = grep exists($record->{$_}), "FS::$table"->virtual_fields;
- } else {
- cluck "warning: FS::$table not loaded; virtual fields not searchable"
- unless $nowarn_classload;
- @virtual_fields = ();
- }
my $statement .= "SELECT $select FROM $stable";
$statement .= " $addl_from" if $addl_from;
- if ( @real_fields or @virtual_fields ) {
+ if ( @real_fields ) {
$statement .= ' WHERE '. join(' AND ',
- get_real_fields($table, $record, \@real_fields) ,
- get_virtual_fields($table, $pkey, $record, \@virtual_fields),
- );
+ get_real_fields($table, $record, \@real_fields));
}
$statement .= " $extra_sql" if defined($extra_sql);
push @statement, $statement;
warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
-
+
foreach my $field (
grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
# grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
# ) or croak "Error executing \"$statement\": ". $sth->errstr;
- $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
+ my $ok = $sth->execute;
+ if (!$ok) {
+ my $error = "Error executing \"$statement\"";
+ $error .= ' (' . join(', ', map {"'$_'"} @value) . ')' if @value;
+ $error .= ': '. $sth->errstr;
+ 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`'.
+
- # virtual fields and blessings are nonsense in a heterogeneous UNION, right?
my $table = $stable[0];
my $pkey = '';
$table = '' if grep { $_ ne $table } @stable;
$pkey = dbdef->table($table)->primary_key if $table;
- my @virtual_fields = ();
- if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
- @virtual_fields = "FS::$table"->virtual_fields;
- } else {
- cluck "warning: FS::$table not loaded; virtual fields not returned either"
- unless $nowarn_classload;
- @virtual_fields = ();
- }
-
my %result;
tie %result, "Tie::IxHash";
my @stuff = @{ $sth->fetchall_arrayref( {} ) };
$sth->finish;
- if ( keys(%result) and @virtual_fields ) {
- $statement =
- "SELECT virtual_field.recnum, part_virtual_field.name, ".
- "virtual_field.value ".
- "FROM part_virtual_field JOIN virtual_field USING (vfieldpart) ".
- "WHERE part_virtual_field.dbtable = '$table' AND ".
- "virtual_field.recnum IN (".
- join(',', keys(%result)). ") AND part_virtual_field.name IN ('".
- join(q!', '!, @virtual_fields) . "')";
- warn "[debug]$me $statement\n" if $DEBUG > 1;
- $sth = $dbh->prepare($statement) or croak "$dbh->errstr doing $statement";
- $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
-
- foreach (@{ $sth->fetchall_arrayref({}) }) {
- my $recnum = $_->{recnum};
- my $name = $_->{name};
- my $value = $_->{value};
- if (exists($result{$recnum})) {
- $result{$recnum}->{$name} = $value;
- }
+ my @return;
+ 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);
}
+
}
- my @return;
- if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
+ 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 ) {
# 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
- && eval 'defined(@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')
+ || $record->isa('FS::payinfo_Mixin') )
+ && $record->payby
+ && !grep { $record->payby eq $_ } @encrypt_payby;
# Set it directly... This may cause a problem in the future...
$record->setfield($field, $record->decrypt($record->getfield($field)));
}
return @return;
}
-## makes this easier to read
+=item _query
-sub get_virtual_fields {
- my $table = shift;
- my $pkey = shift;
- my $record = shift;
- my $virtual_fields = shift;
-
- return
- ( map {
- my $op = '=';
- my $column = $_;
- if ( ref($record->{$_}) ) {
- $op = $record->{$_}{'op'} if $record->{$_}{'op'};
- if ( uc($op) eq 'ILIKE' ) {
- $op = 'LIKE';
- $record->{$_}{'value'} = lc($record->{$_}{'value'});
- $column = "LOWER($_)";
- }
- $record->{$_} = $record->{$_}{'value'};
- }
+Construct the SQL statement and parameter-binding list for qsearch. Takes
+the qsearch parameters.
+
+Returns a hash containing:
+'table': The primary table name (if there is one).
+'statement': The SQL statement itself.
+'bind_type': An arrayref of bind types.
+'value': An arrayref of parameter values.
+'cache': The cache object, if one was passed.
+
+=cut
+
+sub _query {
+ my( @stable, @record, @cache );
+ my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
+ my @debug = ();
+ my $cursor = '';
+ my %union_options = ();
+ if ( ref($_[0]) eq 'ARRAY' ) {
+ my $optlist = shift;
+ %union_options = @_;
+ foreach my $href ( @$optlist ) {
+ push @stable, ( $href->{'table'} or die "table name is required" );
+ push @record, ( $href->{'hashref'} || {} );
+ push @select, ( $href->{'select'} || '*' );
+ push @extra_sql, ( $href->{'extra_sql'} || '' );
+ push @extra_param, ( $href->{'extra_param'} || [] );
+ push @order_by, ( $href->{'order_by'} || '' );
+ push @cache, ( $href->{'cache_obj'} || '' );
+ push @addl_from, ( $href->{'addl_from'} || '' );
+ push @debug, ( $href->{'debug'} || '' );
+ }
+ die "at least one hashref is required" unless scalar(@stable);
+ } elsif ( ref($_[0]) eq 'HASH' ) {
+ my $opt = shift;
+ $stable[0] = $opt->{'table'} or die "table name is required";
+ $record[0] = $opt->{'hashref'} || {};
+ $select[0] = $opt->{'select'} || '*';
+ $extra_sql[0] = $opt->{'extra_sql'} || '';
+ $extra_param[0] = $opt->{'extra_param'} || [];
+ $order_by[0] = $opt->{'order_by'} || '';
+ $cache[0] = $opt->{'cache_obj'} || '';
+ $addl_from[0] = $opt->{'addl_from'} || '';
+ $debug[0] = $opt->{'debug'} || '';
+ } else {
+ ( $stable[0],
+ $record[0],
+ $select[0],
+ $extra_sql[0],
+ $cache[0],
+ $addl_from[0]
+ ) = @_;
+ $select[0] ||= '*';
+ }
+ my $cache = $cache[0];
+
+ my @statement = ();
+ my @value = ();
+ my @bind_type = ();
+
+ my $result_table = $stable[0];
+ foreach my $stable ( @stable ) {
+ #stop altering the caller's hashref
+ my $record = { %{ shift(@record) || {} } };#and be liberal in receipt
+ my $select = shift @select;
+ my $extra_sql = shift @extra_sql;
+ my $extra_param = shift @extra_param;
+ my $order_by = shift @order_by;
+ my $cache = shift @cache;
+ my $addl_from = shift @addl_from;
+ my $debug = shift @debug;
+
+ #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
+ #for jsearch
+ $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
+ $stable = $1;
+
+ $result_table = '' if $result_table ne $stable;
+
+ my $table = $cache ? $cache->table : $stable;
+ my $dbdef_table = dbdef->table($table)
+ or die "No schema for table $table found - ".
+ "do you need to run freeside-upgrade?";
+ my $pkey = $dbdef_table->primary_key;
+
+ my @real_fields = grep exists($record->{$_}), real_fields($table);
+
+ my $statement .= "SELECT $select FROM $stable";
+ $statement .= " $addl_from" if $addl_from;
+ if ( @real_fields ) {
+ $statement .= ' WHERE '. join(' AND ',
+ get_real_fields($table, $record, \@real_fields));
+ }
+
+ $statement .= " $extra_sql" if defined($extra_sql);
+ $statement .= " $order_by" if defined($order_by);
+
+ push @statement, $statement;
+
+ warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
+
+
+ foreach my $field (
+ grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
+ ) {
+
+ my $value = $record->{$field};
+ my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
+ $value = $value->{'value'} if ref($value);
+ my $type = dbdef->table($table)->column($field)->type;
+
+ my $bind_type = _bind_type($type, $value);
+
+ #if ( $DEBUG > 2 ) {
+ # no strict 'refs';
+ # %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
+ # unless keys %TYPE;
+ # warn " bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
+ #}
+
+ push @value, $value;
+ push @bind_type, $bind_type;
- # ... EXISTS ( SELECT name, value FROM part_virtual_field
- # JOIN virtual_field
- # ON part_virtual_field.vfieldpart = virtual_field.vfieldpart
- # WHERE recnum = svc_acct.svcnum
- # AND (name, value) = ('egad', 'brain') )
+ }
+
+ foreach my $param ( @$extra_param ) {
+ my $bind_type = { TYPE => SQL_VARCHAR };
+ my $value = $param;
+ if ( ref($param) ) {
+ $value = $param->[0];
+ my $type = $param->[1];
+ $bind_type = _bind_type($type, $value);
+ }
+ push @value, $value;
+ push @bind_type, $bind_type;
+ }
+ }
- my $value = $record->{$_};
+ my $statement = join( ' ) UNION ( ', @statement );
+ $statement = "( $statement )" if scalar(@statement) > 1;
+ $statement .= " $union_options{order_by}" if $union_options{order_by};
- my $subq;
+ return {
+ statement => $statement,
+ bind_type => \@bind_type,
+ value => \@value,
+ table => $result_table,
+ cache => $cache,
+ };
+}
- $subq = ($value ? 'EXISTS ' : 'NOT EXISTS ') .
- "( SELECT part_virtual_field.name, virtual_field.value ".
- "FROM part_virtual_field JOIN virtual_field ".
- "ON part_virtual_field.vfieldpart = virtual_field.vfieldpart ".
- "WHERE virtual_field.recnum = ${table}.${pkey} ".
- "AND part_virtual_field.name = '${column}'".
- ($value ?
- " AND virtual_field.value ${op} '${value}'"
- : "") . ")";
- $subq;
+# qsearch should eventually use this
+sub _from_hashref {
+ my ($table, $cache, @hashrefs) = @_;
+ my @return;
+ # XXX get rid of these string evals at some point
+ # (when we have time to test it)
+ # my $class = "FS::$table" if $table;
+ # if ( $class and $class->isa('FS::Record') )
+ # if ( $class->can('new') eq \&new )
+ #
+ if ( $table && 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 ) {
+ @return = map {
+ new_or_cached( "FS::$table", { %{$_} }, $cache )
+ } @hashrefs;
+ } else {
+ @return = map {
+ new( "FS::$table", { %{$_} } )
+ } @hashrefs;
+ }
+ } else {
+ #okay, its been tested
+ # warn "untested code (class FS::$table uses custom new method)";
+ @return = map {
+ eval 'FS::'. $table. '->new( { %{$_} } )';
+ } @hashrefs;
+ }
- } @{ $virtual_fields } ) ;
+ # Check for encrypted fields and decrypt them.
+ ## only in the local copy, not the cached object
+ if ( $conf_encryption
+ && 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')
+ || $record->isa('FS::payinfo_Mixin') )
+ && $record->payby
+ && !grep { $record->payby eq $_ } @encrypt_payby;
+ # Set it directly... This may cause a problem in the future...
+ $record->setfield($field, $record->decrypt($record->getfield($field)));
+ }
+ }
+ }
+ } else {
+ cluck "warning: FS::$table not loaded; returning FS::Record objects"
+ unless $nowarn_classload;
+ @return = map {
+ FS::Record->new( $table, { %{$_} } );
+ } @hashrefs;
+ }
+ return @return;
}
sub get_real_fields {
my $record = shift;
my $real_fields = shift;
- ## this huge map was previously inline, just broke it out to help read the qsearch method, should be optimized for readability
- return (
- map {
+ ## could be optimized more for readability
+ return (
+ map {
my $op = '=';
my $column = $_;
+ my $table_column = $qsearch_qualify_columns ? "$table.$column" : $column;
my $type = dbdef->table($table)->column($column)->type;
my $value = $record->{$column};
$value = $value->{'value'} if ref($value);
- if ( ref($record->{$_}) ) {
- $op = $record->{$_}{'op'} if $record->{$_}{'op'};
+
+ if ( ref($record->{$column}) ) {
+ $op = $record->{$column}{'op'} if $record->{$column}{'op'};
#$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
if ( uc($op) eq 'ILIKE' ) {
$op = 'LIKE';
- $record->{$_}{'value'} = lc($record->{$_}{'value'});
- $column = "LOWER($_)";
+ $record->{$column}{'value'} = lc($record->{$column}{'value'});
+ $table_column = "LOWER($table_column)";
}
- $record->{$_} = $record->{$_}{'value'}
+ $record->{$column} = $record->{$column}{'value'}
}
- if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
+ if ( ! defined( $record->{$column} ) || $record->{$column} eq '' ) {
if ( $op eq '=' ) {
if ( driver_name eq 'Pg' ) {
if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
- qq-( $column IS NULL )-;
+ qq-( $table_column IS NULL )-;
} else {
- qq-( $column IS NULL OR $column = '' )-;
+ qq-( $table_column IS NULL OR $table_column = '' )-;
}
} else {
- qq-( $column IS NULL OR $column = "" )-;
+ qq-( $table_column IS NULL OR $table_column = "" )-;
}
} elsif ( $op eq '!=' ) {
if ( driver_name eq 'Pg' ) {
if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
- qq-( $column IS NOT NULL )-;
+ qq-( $table_column IS NOT NULL )-;
} else {
- qq-( $column IS NOT NULL AND $column != '' )-;
+ qq-( $table_column IS NOT NULL AND $table_column != '' )-;
}
} else {
- qq-( $column IS NOT NULL AND $column != "" )-;
+ qq-( $table_column IS NOT NULL AND $table_column != "" )-;
}
} else {
if ( driver_name eq 'Pg' ) {
- qq-( $column $op '' )-;
+ qq-( $table_column $op '' )-;
} else {
- qq-( $column $op "" )-;
+ qq-( $table_column $op "" )-;
}
}
+ } elsif ( $op eq '!=' ) {
+ qq-( $table_column IS NULL OR $table_column != ? )-;
#if this needs to be re-enabled, it needs to use a custom op like
#"APPROX=" or something (better name?, not '=', to avoid affecting other
# searches
#} elsif ( $op eq 'APPROX=' && _is_fs_float( $type, $value ) ) {
- # ( "$column <= ?", "$column >= ?" );
+ # ( "$table_column <= ?", "$table_column >= ?" );
} else {
- "$column $op ?";
+ "$table_column $op ?";
}
- } @{ $real_fields } );
+
+ } @{ $real_fields }
+ );
}
=item by_key PRIMARY_KEY_VALUE
method calls. Interface will almost definately change in an incompatible
fashion.
-Arguments:
+Arguments:
=cut
# to avoid "Use of unitialized value" errors
if ( defined ( $self->{Hash}->{$field} ) ) {
$self->{Hash}->{$field};
- } else {
+ } else {
'';
}
}
=cut
-sub set {
+sub set {
my($self,$field,$value) = @_;
$self->{'modified'} = 1;
$self->{'Hash'}->{$field} = $value;
confess "errant AUTOLOAD $field for $self (no args)"
unless blessed($self) && $self->can('getfield');
$self->getfield($field);
- }
+ }
}
# efficient
# $_[0]->setfield($field, $_[1]);
# } else {
# $_[0]->getfield($field);
-# }
+# }
#}
=item hash
my($self) = @_;
confess $self. ' -> hash: Hash attribute is undefined'
unless defined($self->{'Hash'});
- %{ $self->{'Hash'} };
+ %{ $self->{'Hash'} };
}
=item hashref
my $error = $self->check;
return $error if $error;
- #single-field unique keys are given a value if false
+ #single-field non-null unique keys are given a value if empty
#(like MySQL's AUTO_INCREMENT or Pg SERIAL)
foreach ( $self->dbdef_table->unique_singles) {
- $self->unique($_) unless $self->getfield($_);
+ next if $self->getfield($_);
+ next if $self->dbdef_table->column($_)->null eq 'NULL';
+ $self->unique($_);
}
#and also the primary key, if the database isn't going to
}
my $table = $self->table;
-
+
# Encrypt before the database
- if ( defined(eval '@FS::'. $table . '::encrypted_fields')
- && scalar( eval '@FS::'. $table . '::encrypted_fields')
- && $conf->exists('encryption')
+ if ( scalar( eval '@FS::'. $table . '::encrypted_fields')
+ && $conf_encryption
) {
foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
- $self->{'saved'} = $self->getfield($field);
+ next if $field eq 'payinfo'
+ && ($self->isa('FS::payinfo_transaction_Mixin')
+ || $self->isa('FS::payinfo_Mixin') )
+ && $self->payby
+ && !grep { $self->payby eq $_ } @encrypt_payby;
+ $saved->{$field} = $self->getfield($field);
$self->setfield($field, $self->encrypt($self->getfield($field)));
}
}
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';
# 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' ) {
} 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?)";
}
}
- my @virtual_fields =
- grep defined($self->getfield($_)) && $self->getfield($_) ne "",
- $self->virtual_fields;
- if (@virtual_fields) {
- my %v_values = map { $_, $self->getfield($_) } @virtual_fields;
-
- my $vfieldpart = $self->vfieldpart_hashref;
-
- my $v_statement = "INSERT INTO virtual_field(recnum, vfieldpart, value) ".
- "VALUES (?, ?, ?)";
-
- my $v_sth = dbh->prepare($v_statement) or do {
- dbh->rollback if $FS::UID::AutoCommit;
- return dbh->errstr;
- };
-
- foreach (keys(%v_values)) {
- $v_sth->execute($self->getfield($primary_key),
- $vfieldpart->{$_},
- $v_values{$_})
- or do {
- dbh->rollback if $FS::UID::AutoCommit;
- return $v_sth->errstr;
- };
- }
- }
-
-
my $h_sth;
- if ( defined dbdef->table('h_'. $table) ) {
+ if ( defined( dbdef->table('h_'. $table) ) && ! $no_history ) {
my $h_statement = $self->_h_statement('insert');
warn "[debug]$me $h_statement\n" if $DEBUG > 2;
$h_sth = dbh->prepare($h_statement) or do {
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});
}
my $primary_key = $self->dbdef_table->primary_key;
- my $v_sth;
- my @del_vfields;
- my $vfp = $self->vfieldpart_hashref;
- foreach($self->virtual_fields) {
- next if $self->getfield($_) eq '';
- unless(@del_vfields) {
- my $st = "DELETE FROM virtual_field WHERE recnum = ? AND vfieldpart = ?";
- $v_sth = dbh->prepare($st) or return dbh->errstr;
- }
- push @del_vfields, $_;
- }
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';
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;
- $v_sth->execute($self->getfield($primary_key), $vfp->{$_})
- or return $v_sth->errstr
- foreach (@del_vfields);
-
+
dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
#no need to needlessly destoy the data either (causes problems actually)
my $error = $new->check;
return $error if $error;
-
+
# Encrypt for replace
my $saved = {};
- if ( $conf->exists('encryption')
- && defined(eval '@FS::'. $new->table . '::encrypted_fields')
- && scalar( eval '@FS::'. $new->table . '::encrypted_fields')
+ 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')
+ || $new->isa('FS::payinfo_Mixin') )
+ && $new->payby
+ && !grep { $new->payby eq $_ } @encrypt_payby;
$saved->{$field} = $new->getfield($field);
$new->setfield($field, $new->encrypt($new->getfield($field)));
}
#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 $new -> replace $old: records identical"
+ carp "[warning]$me ". ref($new)."->replace ".
+ ( $primary_key ? "$primary_key ".$new->get($primary_key) : '' ).
+ ": records identical"
unless $nowarn_identical;
return '';
}
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 ',
$h_new_sth = '';
}
- # For virtual fields we have three cases with different SQL
- # statements: add, replace, delete
- my $v_add_sth;
- my $v_rep_sth;
- my $v_del_sth;
- my (@add_vfields, @rep_vfields, @del_vfields);
- my $vfp = $old->vfieldpart_hashref;
- foreach(grep { exists($diff{$_}) } $new->virtual_fields) {
- if($diff{$_} eq '') {
- # Delete
- unless(@del_vfields) {
- my $st = "DELETE FROM virtual_field WHERE recnum = ? ".
- "AND vfieldpart = ?";
- warn "[debug]$me $st\n" if $DEBUG > 2;
- $v_del_sth = dbh->prepare($st) or return dbh->errstr;
- }
- push @del_vfields, $_;
- } elsif($old->getfield($_) eq '') {
- # Add
- unless(@add_vfields) {
- my $st = "INSERT INTO virtual_field (value, recnum, vfieldpart) ".
- "VALUES (?, ?, ?)";
- warn "[debug]$me $st\n" if $DEBUG > 2;
- $v_add_sth = dbh->prepare($st) or return dbh->errstr;
- }
- push @add_vfields, $_;
- } else {
- # Replace
- unless(@rep_vfields) {
- my $st = "UPDATE virtual_field SET value = ? ".
- "WHERE recnum = ? AND vfieldpart = ?";
- warn "[debug]$me $st\n" if $DEBUG > 2;
- $v_rep_sth = dbh->prepare($st) or return dbh->errstr;
- }
- push @rep_vfields, $_;
- }
- }
-
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';
$h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
$h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
- $v_del_sth->execute($old->getfield($primary_key),
- $vfp->{$_})
- or return $v_del_sth->errstr
- foreach(@del_vfields);
-
- $v_add_sth->execute($new->getfield($_),
- $old->getfield($primary_key),
- $vfp->{$_})
- or return $v_add_sth->errstr
- foreach(@add_vfields);
-
- $v_rep_sth->execute($new->getfield($_),
- $old->getfield($primary_key),
- $vfp->{$_})
- or return $v_rep_sth->errstr
- foreach(@rep_vfields);
-
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});
=item check
-Checks virtual fields (using check_blocks). Subclasses should still provide
-a check method to validate real fields, foreign keys, etc., and call this
-method via $self->SUPER::check.
-
-(FIXME: Should this method try to make sure that it I<is> being called from
-a subclass's check method, to keep the current semantics as far as possible?)
+Checks custom fields. Subclasses should still provide a check method to validate
+non-custom fields, foreign keys, etc., and call this method via $self->SUPER::check.
=cut
sub check {
- #confess "FS::Record::check not implemented; supply one in subclass!";
- my $self = shift;
-
- foreach my $field ($self->virtual_fields) {
- for ($self->getfield($field)) {
- # See notes on check_block in FS::part_virtual_field.
- eval $self->pvf($field)->check_block;
- if ( $@ ) {
- #this is bad, probably want to follow the stack backtrace up and see
- #wtf happened
- my $err = "Fatal error checking $field for $self";
- cluck "$err: $@";
- return "$err (see log for backtrace): $@";
-
- }
- $self->setfield($field, $_);
+ my $self = shift;
+ foreach my $field ($self->virtual_fields) {
+ my $error = $self->ut_textn($field);
+ return $error if $error;
}
- }
- '';
+ '';
}
-=item process_batch_import JOB OPTIONS_HASHREF PARAMS
-
-Processes a batch import as a queued JSRPC job
-
-JOB is an FS::queue entry.
+=item virtual_fields [ TABLE ]
-OPTIONS_HASHREF can have the following keys:
+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.
-=over 4
+=cut
-=item table
+sub virtual_fields {
+ my $self = shift;
+ my $table;
+ $table = $self->table or confess "virtual_fields called on non-table";
-Table name (required).
+ confess "Unknown table $table" unless dbdef->table($table);
-=item params
+ return () unless dbdef->table('part_virtual_field');
-Listref of field names for static fields. They will be given values from the
+ unless ( $virtual_fields_cache{$table} ) {
+ my $concat = [ "'cf_'", "name" ];
+ my $query = "SELECT ".concat_sql($concat).' from part_virtual_field ' .
+ "WHERE dbtable = '$table'";
+ my $dbh = dbh;
+ my $result = $dbh->selectcol_arrayref($query);
+ confess "Error executing virtual fields query: $query: ". $dbh->errstr
+ if $dbh->err;
+ $virtual_fields_cache{$table} = $result;
+ }
+
+ @{$virtual_fields_cache{$table}};
+
+}
+
+=item process_batch_import JOB OPTIONS_HASHREF PARAMS
+
+Processes a batch import as a queued JSRPC job
+
+JOB is an FS::queue entry.
+
+OPTIONS_HASHREF can have the following keys:
+
+=over 4
+
+=item table
+
+Table name (required).
+
+=item params
+
+Arrayref of field names for static fields. They will be given values from the
PARAMS hashref and passed as a "params" hashref to batch_import.
=item formats
=back
-PARAMS is a base64-encoded Storable string containing the POSTed data as
-a hash ref. It normally contains at least one field, "uploaded files",
-generated by /elements/file-upload.html and containing the list of uploaded
-files. Currently only supports a single file named "file".
+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".
=cut
+# uploaded_files is kind of bizarre; fix that some time
+
use Storable qw(thaw);
use Data::Dumper;
use MIME::Base64;
my @pass_params = $opt->{params} ? @{ $opt->{params} } : ();
my %formats = %{ $opt->{formats} };
- my $param = thaw(decode_base64(shift));
+ my $param = shift;
+ # because some job-spawning code (JSRPC) pre-freezes the arguments,
+ # and then the 'frozen' attribute doesn't get set, and thus $job->args
+ # doesn't know to thaw them, we have to do this everywhere.
+ if (!ref $param) {
+ $param = thaw(decode_base64($param));
+ }
warn Dumper($param) if $DEBUG;
-
+
my $files = $param->{'uploaded_files'}
or die "No files provided.\n";
format_headers => $opt->{format_headers},
format_sep_chars => $opt->{format_sep_chars},
format_fixedlength_formats => $opt->{format_fixedlength_formats},
+ format_xml_formats => $opt->{format_xml_formats},
+ format_asn_formats => $opt->{format_asn_formats},
format_row_callbacks => $opt->{format_row_callbacks},
+ format_hash_callbacks => $opt->{format_hash_callbacks},
#per-import
job => $job,
file => $file,
params => { map { $_ => $param->{$_} } @pass_params },
#?
default_csv => $opt->{default_csv},
+ preinsert_callback => $opt->{preinsert_callback},
+ postinsert_callback => $opt->{postinsert_callback},
+ insert_args_callback => $opt->{insert_args_callback},
);
if ( $opt->{'batch_namecol'} ) {
=item format_row_callbacks
+=item format_hash_callbacks - After parsing, before object creation
+
=item fields - Alternate way to specify import, specifying import fields directly as a listref
+=item preinsert_callback
+
=item postinsert_callback
=item params
=item type
-csv, xls or fixedlength
+csv, xls, fixedlength, xml
=item empty_ok
my $file = $param->{file};
my $params = $param->{params} || {};
- my( $type, $header, $sep_char, $fixedlength_format, $row_callback, @fields );
+ my $custnum_prefix = $conf->config('cust_main-custnum-display_prefix');
+ my $custnum_length = $conf->config('cust_main-custnum-display_length') || 8;
+
+ my( $type, $header, $sep_char,
+ $fixedlength_format, $xml_format, $asn_format,
+ $parser_opt, $row_callback, $hash_callback, @fields );
+
my $postinsert_callback = '';
+ $postinsert_callback = $param->{'postinsert_callback'}
+ if $param->{'postinsert_callback'};
+ my $preinsert_callback = '';
+ $preinsert_callback = $param->{'preinsert_callback'}
+ if $param->{'preinsert_callback'};
+ my $insert_args_callback = '';
+ $insert_args_callback = $param->{'insert_args_callback'}
+ if $param->{'insert_args_callback'};
+
if ( $param->{'format'} ) {
my $format = $param->{'format'};
? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
: '';
+ $parser_opt =
+ $param->{'format_parser_opts'}
+ ? $param->{'format_parser_opts'}{ $param->{'format'} }
+ : {};
+
+ $xml_format =
+ $param->{'format_xml_formats'}
+ ? $param->{'format_xml_formats'}{ $param->{'format'} }
+ : '';
+
+ $asn_format =
+ $param->{'format_asn_formats'}
+ ? $param->{'format_asn_formats'}{ $param->{'format'} }
+ : '';
+
$row_callback =
$param->{'format_row_callbacks'}
? $param->{'format_row_callbacks'}{ $param->{'format'} }
: '';
+ $hash_callback =
+ $param->{'format_hash_callbacks'}
+ ? $param->{'format_hash_callbacks'}{ $param->{'format'} }
+ : '';
+
@fields = @{ $formats->{ $format } };
} elsif ( $param->{'fields'} ) {
$sep_char = ',';
$fixedlength_format = '';
$row_callback = '';
+ $hash_callback = '';
@fields = @{ $param->{'fields'} };
- $postinsert_callback = $param->{'postinsert_callback'}
- if $param->{'postinsert_callback'}
-
} else {
die "neither format nor fields specified";
}
my $count;
my $parser;
my @buffer = ();
+ my $asn_header_buffer;
if ( $type eq 'csv' || $type eq 'fixedlength' ) {
if ( $type eq 'csv' ) {
- my %attr = ();
- $attr{sep_char} = $sep_char if $sep_char;
- $parser = new Text::CSV_XS \%attr;
+ $parser_opt->{'binary'} = 1;
+ $parser_opt->{'sep_char'} = $sep_char if $sep_char;
+ $parser = Text::CSV_XS->new($parser_opt);
} elsif ( $type eq 'fixedlength' ) {
eval "use Parse::FixedLength;";
die $@ if $@;
- $parser = new Parse::FixedLength $fixedlength_format;
-
+ $parser = Parse::FixedLength->new($fixedlength_format, $parser_opt);
+
} else {
die "Unknown file type $type\n";
}
$row = $header || 0;
+ } elsif ( $type eq 'xml' ) {
+
+ # FS::pay_batch
+ eval "use XML::Simple;";
+ die $@ if $@;
+ my $xmlrow = $xml_format->{'xmlrow'};
+ $parser = $xml_format->{'xmlkeys'};
+ die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
+ my $data = XML::Simple::XMLin(
+ $file,
+ 'SuppressEmpty' => '', #sets empty values to ''
+ 'KeepRoot' => 1,
+ );
+ my $rows = $data;
+ $rows = $rows->{$_} foreach @$xmlrow;
+ $rows = [ $rows ] if ref($rows) ne 'ARRAY';
+ $count = @buffer = @$rows;
+
+ } elsif ( $type eq 'asn.1' ) {
+
+ eval "use Convert::ASN1";
+ die $@ if $@;
+
+ my $asn = Convert::ASN1->new;
+ $asn->prepare( $asn_format->{'spec'} ) or die $asn->error;
+
+ $parser = $asn->find( $asn_format->{'macro'} ) or die $asn->error;
+
+ my $data = slurp($file);
+ my $asn_output = $parser->decode( $data )
+ or return "No ". $asn_format->{'macro'}. " found\n";
+
+ $asn_header_buffer = &{ $asn_format->{'header_buffer'} }( $asn_output );
+
+ my $rows = &{ $asn_format->{'arrayref'} }( $asn_output );
+ $count = @buffer = @$rows;
+
} else {
die "Unknown file type $type\n";
}
while (1) {
my @columns = ();
+ my %hash = %$params;
if ( $type eq 'csv' ) {
last unless scalar(@buffer);
$line = &{$row_callback}($line) if $row_callback;
+ next if $line =~ /^\s*$/; #skip empty lines
+
$parser->parse($line) or do {
$dbh->rollback if $oldAutoCommit;
- return "can't parse: ". $parser->error_input();
+ return "can't parse: ". $parser->error_input() . " " . $parser->error_diag;
};
@columns = $parser->fields();
} elsif ( $type eq 'fixedlength' ) {
+ last unless scalar(@buffer);
+ $line = shift(@buffer);
+
@columns = $parser->parse($line);
} elsif ( $type eq 'xls' ) {
#my $z = 'A';
#warn $z++. ": $_\n" for @columns;
+ } elsif ( $type eq 'xml' ) {
+
+ # $parser = [ 'Column0Key', 'Column1Key' ... ]
+ last unless scalar(@buffer);
+ my $row = shift @buffer;
+ @columns = @{ $row }{ @$parser };
+
+ } elsif ( $type eq 'asn.1' ) {
+
+ last unless scalar(@buffer);
+ my $row = shift @buffer;
+ &{ $asn_format->{row_callback} }( $row, $asn_header_buffer )
+ if $asn_format->{row_callback};
+ foreach my $key ( keys %{ $asn_format->{map} } ) {
+ $hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer );
+ }
+
} else {
die "Unknown file type $type\n";
}
my @later = ();
- my %hash = %$params;
foreach my $field ( @fields ) {
my $value = shift @columns;
-
+
if ( ref($field) eq 'CODE' ) {
#&{$field}(\%hash, $value);
push @later, $field, $value;
}
+ if ( $custnum_prefix && $hash{custnum} =~ /^$custnum_prefix(0*([1-9]\d*))$/
+ && length($1) == $custnum_length ) {
+ $hash{custnum} = $2;
+ }
+
+ %hash = &{$hash_callback}(%hash) if $hash_callback;
+
#my $table = $param->{table};
my $class = "FS::$table";
}
next if exists( $param->{skiprow} );
- my $error = $record->insert;
+ if ( $preinsert_callback ) {
+ my $error = &{$preinsert_callback}($record, $param);
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "preinsert_callback error". ( $line ? " for $line" : '' ).
+ ": $error";
+ }
+ next if exists $param->{skiprow} && $param->{skiprow};
+ }
+
+ my @insert_args = ();
+ if ( $insert_args_callback ) {
+ @insert_args = &{$insert_args_callback}($record, $param);
+ }
+
+ my $error = $record->insert(@insert_args);
if ( $error ) {
$dbh->rollback if $oldAutoCommit;
return "Empty file!";
}
- $dbh->commit or die $dbh->errstr if $oldAutoCommit;;
+ $dbh->commit or die $dbh->errstr if $oldAutoCommit;
''; #no error
;
# If we're encrypting then don't store the payinfo in the history
- if ( $conf && $conf->exists('encryption') ) {
+ if ( $conf_encryption && $self->table ne 'banned_pay' ) {
@fields = grep { $_ ne 'payinfo' } @fields;
}
"INSERT INTO h_". $self->table. " ( ".
join(', ', qw(history_date history_user history_action), @fields ).
") VALUES (".
- join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values).
+ join(', ', $time,
+ dbh->quote($FS::CurrentUser::CurrentUser->username),
+ dbh->quote($action),
+ @values
+ ).
")"
;
}
=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
'';
}
+=item ut_decimal COLUMN[, DIGITS]
+
+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]
+
+Check/untaint decimal numbers. May be null. If there is an error, returns
+the error, otherwise returns false.
+
+=cut
+
+sub ut_decimal {
+ my($self, $field, $digits) = @_;
+ $digits ||= '';
+ $self->getfield($field) =~ /^\s*(\d+(\.\d{0,$digits})?)\s*$/
+ or return "Illegal or empty (decimal) $field: ".$self->getfield($field);
+ $self->setfield($field, $1);
+ '';
+}
+
+sub ut_decimaln {
+ my($self, $field, $digits) = @_;
+ $self->getfield($field) =~ /^\s*(\d*(\.\d{0,$digits})?)\s*$/
+ or return "Illegal (decimal) $field: ".$self->getfield($field);
+ $self->setfield($field, $1);
+ '';
+}
+
=item ut_money COLUMN
Check/untaint monetary numbers. May be negative. Set to 0 if null. If there
sub ut_money {
my($self,$field)=@_;
- $self->setfield($field, 0) if $self->getfield($field) eq '';
- $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/
- or return "Illegal (money) $field: ". $self->getfield($field);
- #$self->setfield($field, "$1$2$3" || 0);
- $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
+
+ if ( $self->getfield($field) eq '' ) {
+ $self->setfield($field, 0);
+ } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{1})\s*$/ ) {
+ #handle one decimal place without barfing out
+ $self->setfield($field, ( ($1||''). ($2||''). ($3.'0') ) || 0);
+ } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ ) {
+ $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
+ } else {
+ return "Illegal (money) $field: ". $self->getfield($field);
+ }
+
'';
}
=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.
#warn "msgcat ". \&msgcat. "\n";
#warn "notexist ". \¬exist. "\n";
#warn "AUTOLOAD ". \&AUTOLOAD. "\n";
+ # \p{Word} = alphanumerics, marks (diacritics), and connectors
+ # see perldoc perluniprops
$self->getfield($field)
- =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>]+)$/
+ =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>\~$money_char]+)$/
or return gettext('illegal_or_empty_text'). " $field: ".
$self->getfield($field);
$self->setfield($field,$1);
=item ut_textn COLUMN
Check/untaint text. Alphanumerics, spaces, and the following punctuation
-symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? /
+symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
May be null. If there is an error, returns the error, otherwise returns false.
=cut
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);
'';
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);
'';
Check/untaint phone numbers. May be null. If there is an error, returns
the error, otherwise returns false.
-Takes an optional two-letter ISO country code; without it or with unsupported
-countries, ut_phonen simply calls ut_alphan.
+Takes an optional two-letter ISO 3166-1 alpha-2 country code; without
+it or with unsupported countries, ut_phonen simply calls ut_alphan.
=cut
$self->setfield($field, uc($1));
'';
}
+
+=item ut_mac_addr COLUMN
+
+Check/untaint mac addresses. May be null.
+
+=cut
+
+sub ut_mac_addr {
+ my($self, $field) = @_;
+
+ my $mac = $self->get($field);
+ $mac =~ s/\s+//g;
+ $mac =~ s/://g;
+ $self->set($field, $mac);
+
+ my $e = $self->ut_hex($field);
+ return $e if $e;
+
+ return "Illegal (mac address) $field: ". $self->getfield($field)
+ unless length($self->getfield($field)) == 12;
+
+ '';
+
+}
+
+=item ut_mac_addrn COLUMN
+
+Check/untaint mac addresses. May be null.
+
+=cut
+
+sub ut_mac_addrn {
+ my($self, $field) = @_;
+ ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
+}
+
=item ut_ip COLUMN
Check/untaint ip addresses. IPv4 only for now, though ::1 is auto-translated
$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");
+ $self->setfield( $field, $self->_ut_ip_strip_leading_zeros( "$1.$2.$3.$4" ));
'';
}
}
}
+=item ut_ip46 COLUMN
+
+Check/untaint IPv4 or IPv6 address.
+
+=cut
+
+sub ut_ip46 {
+ my( $self, $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 '';
+}
+
+=item ut_ip46n
+
+Check/untaint IPv6 or IPv6 address. May be null.
+
+=cut
+
+sub ut_ip46n {
+ my( $self, $field ) = @_;
+ if ( $self->getfield($field) =~ /^$/ ) {
+ $self->setfield($field, '');
+ return '';
+ }
+ $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.
=cut
sub ut_coord {
-
my ($self, $field) = (shift, shift);
- my $lower = shift if scalar(@_);
- my $upper = shift if scalar(@_);
+ my($lower, $upper);
+ if ( $field =~ /latitude/ ) {
+ $lower = $lat_lower;
+ $upper = 90;
+ } elsif ( $field =~ /longitude/ ) {
+ $lower = -180;
+ $upper = $lon_upper;
+ }
+
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 ($self, $field) = (shift, shift);
- if ($self->getfield($field) =~ /^$/) {
+ if ($self->getfield($field) =~ /^\s*$/) {
return '';
} else {
return $self->ut_coord($field, @_);
}
-
=item ut_domain COLUMN
-Check/untaint host and domain names.
+Check/untaint host and domain names. May not be null.
=cut
my( $self, $field ) = @_;
#$self->getfield($field) =~/^(\w+\.)*\w+$/
$self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
- or return "Illegal (domain) $field: ". $self->getfield($field);
+ or return "Illegal (hostname) $field: ". $self->getfield($field);
$self->setfield($field,$1);
'';
}
+=item ut_domainn COLUMN
+
+Check/untaint host and domain names. May be null.
+
+=cut
+
+sub ut_domainn {
+ my( $self, $field ) = @_;
+ if ( $self->getfield($field) =~ /^()$/ ) {
+ $self->setfield($field,'');
+ '';
+ } else {
+ $self->ut_domain($field);
+ }
+}
+
=item ut_name COLUMN
Check/untaint proper names; allows alphanumerics, spaces and the following
sub ut_name {
my( $self, $field ) = @_;
- $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
+# warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n";
+ $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/
or return gettext('illegal_name'). " $field: ". $self->getfield($field);
- $self->setfield($field,$1);
+ my $name = $1;
+ $name =~ s/^\s+//;
+ $name =~ s/\s+$//;
+ $name =~ s/\s+/ /g;
+ $self->setfield($field, $name);
'';
}
+=item ut_namen COLUMN
+
+Check/untaint proper names; allows alphanumerics, spaces and the following
+punctuation: , . - '
+
+May not be null.
+
+=cut
+
+sub ut_namen {
+ my( $self, $field ) = @_;
+ return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
+ $self->ut_name($field);
+}
+
=item ut_zip COLUMN
Check/untaint zip codes.
$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*$/
{
$self->setfield($field,'');
} else {
- $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
+ $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/
or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
$self->setfield($field,$1);
}
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)));
}
return "Illegal (enum) field $field: ". $self->getfield($field);
}
+=item ut_enumn COLUMN CHOICES_ARRAYREF
+
+Like ut_enum, except the null value is also allowed.
+
+=cut
+
+sub ut_enumn {
+ my( $self, $field, $choices ) = @_;
+ $self->getfield($field)
+ ? $self->ut_enum($field, $choices)
+ : '';
+}
+
+=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
+is the standard form for boolean flags in Freeside.
+
+=cut
+
+sub ut_flag {
+ my( $self, $field ) = @_;
+ my $value = uc($self->getfield($field));
+ if ( $value eq '' or $value eq 'Y' ) {
+ $self->setfield($field, $value);
+ return '';
+ }
+ return "Illegal (flag) field $field: $value";
+}
+
=item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
Check/untaint a foreign column key. Call a regular ut_ method (like ut_number)
}
-=item virtual_fields [ TABLE ]
-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.
+=item ut_email COLUMN
+
+Check column contains a valid E-Mail address
=cut
-sub virtual_fields {
- my $self = shift;
- my $table;
- $table = $self->table or confess "virtual_fields called on non-table";
+sub ut_email {
+ my ( $self, $field ) = @_;
+ Email::Valid->address( $self->getfield( $field ) )
+ ? ''
+ : "Illegal (email) field $field: ". $self->getfield( $field );
+}
- confess "Unknown table $table" unless dbdef->table($table);
+=item ut_emailn COLUMN
- return () unless dbdef->table('part_virtual_field');
+Check column contains a valid E-Mail address
- unless ( $virtual_fields_cache{$table} ) {
- my $query = 'SELECT name from part_virtual_field ' .
- "WHERE dbtable = '$table'";
- my $dbh = dbh;
- my $result = $dbh->selectcol_arrayref($query);
- confess "Error executing virtual fields query: $query: ". $dbh->errstr
- if $dbh->err;
- $virtual_fields_cache{$table} = $result;
- }
+May be null
- @{$virtual_fields_cache{$table}};
+=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).
+
+=cut
+
+sub trim_whitespace {
+ my $self = shift;
+ foreach my $field (@_) {
+ my $value = $self->get($field);
+ $value =~ s/^\s+//;
+ $value =~ s/\s+$//;
+ $self->set($field, $value);
+ }
+}
=item fields [ TABLE ]
-This is a wrapper for real_fields and virtual_fields. Code that called
+This is a wrapper for real_fields. Code that called
fields before should probably continue to call fields.
=cut
$table = $something;
$something = "FS::$table";
}
- return (real_fields($table), $something->virtual_fields());
+ return (real_fields($table));
}
-=item pvf FIELD_NAME
-
-Returns the FS::part_virtual_field object corresponding to a field in the
-record (specified by FIELD_NAME).
-
-=cut
-
-sub pvf {
- my ($self, $name) = (shift, shift);
-
- if(grep /^$name$/, $self->virtual_fields) {
- return qsearchs('part_virtual_field', { dbtable => $self->table,
- name => $name } );
- }
- ''
-}
-
-=item vfieldpart_hashref TABLE
-
-Returns a hashref of virtual field names and vfieldparts applicable to the given
-TABLE.
-
-=cut
-
-sub vfieldpart_hashref {
- my $self = shift;
- my $table = $self->table;
-
- return {} unless dbdef->table('part_virtual_field');
-
- my $dbh = dbh;
- my $statement = "SELECT vfieldpart, name FROM part_virtual_field WHERE ".
- "dbtable = '$table'";
- my $sth = $dbh->prepare($statement);
- $sth->execute or croak "Execution of '$statement' failed: ".$dbh->errstr;
- return { map { $_->{name}, $_->{vfieldpart} }
- @{$sth->fetchall_arrayref({})} };
-
-}
=item encrypt($value)
sub encrypt {
my ($self, $value) = @_;
- my $encrypted;
+ my $encrypted = $value;
- if ($conf->exists('encryption')) {
+ if ($conf_encryption) {
if ($self->is_encrypted($value)) {
# Return the original value if it isn't plaintext.
$encrypted = $value;
sub decrypt {
my ($self,$value) = @_;
my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
- if ($conf->exists('encryption') && $self->is_encrypted($value)) {
+ if ($conf_encryption && $self->is_encrypted($value)) {
$self->loadRSA;
if (ref($rsa_decrypt) =~ /::RSA/) {
my $encrypted = unpack ("u*", $value);
#Initialize the Module
$rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
- if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') {
- $rsa_module = $conf->config('encryptionmodule');
+ if ($conf_encryptionmodule && $conf_encryptionmodule ne '') {
+ $rsa_module = $conf_encryptionmodule;
}
if (!$rsa_loaded) {
$rsa_loaded++;
}
# Initialize Encryption
- if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') {
- my $public_key = join("\n",$conf->config('encryptionpublickey'));
- $rsa_encrypt = $rsa_module->new_public_key($public_key);
+ if ($conf_encryptionpublickey && $conf_encryptionpublickey ne '') {
+ $rsa_encrypt = $rsa_module->new_public_key($conf_encryptionpublickey);
}
-
+
# Intitalize Decryption
- if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') {
- my $private_key = join("\n",$conf->config('encryptionprivatekey'));
- $rsa_decrypt = $rsa_module->new_private_key($private_key);
+ if ($conf_encryptionprivatekey && $conf_encryptionprivatekey ne '') {
+ $rsa_decrypt = $rsa_module->new_private_key($conf_encryptionprivatekey);
}
}
my $sth = dbh->prepare($sql) or die dbh->errstr;
$sth->execute(@_)
or die "Unexpected error executing statement $sql: ". $sth->errstr;
- my $scalar = $sth->fetchrow_arrayref->[0];
+ my $row = $sth->fetchrow_arrayref or return '';
+ my $scalar = $row->[0];
defined($scalar) ? $scalar : '';
}
+=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
+associated table.
+
+=cut
+
+sub count {
+ my($self, $where) = (shift, shift);
+ my $table = $self->table or die 'count called on object of class '.ref($self);
+ my $sql = "SELECT COUNT(*) FROM $table";
+ $sql .= " WHERE $where" if $where;
+ $self->scalar_sql($sql, @_);
+}
+
+=item row_exists [ WHERE [, PLACEHOLDER ...] ]
+
+Convenience method for the common case of "SELECT 1 FROM table ... LIMIT 1"
+with optional (but almost always needed) WHERE.
+
+=cut
+
+sub row_exists {
+ my($self, $where) = (shift, shift);
+ my $table = $self->table or die 'row_exists called on object of class '.ref($self);
+ my $sql = "SELECT 1 FROM $table";
+ $sql .= " WHERE $where" if $where;
+ $sql .= " LIMIT 1";
+ $self->scalar_sql($sql, @_);
+}
+
=back
=head1 SUBROUTINES
=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
$table_obj->columns;
}
+=item pvf FIELD_NAME
+
+Returns the FS::part_virtual_field object corresponding to a field in the
+record (specified by FIELD_NAME).
+
+=cut
+
+sub pvf {
+ my ($self, $name) = (shift, shift);
+
+ if(grep /^$name$/, $self->virtual_fields) {
+ $name =~ s/^cf_//;
+ my $concat = [ "'cf_'", "name" ];
+ return qsearchs({ table => 'part_virtual_field',
+ hashref => { dbtable => $self->table,
+ name => $name
+ },
+ select => 'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
+ });
+ }
+ ''
+}
+
=item _quote VALUE, TABLE, COLUMN
This is an internal function used to construct SQL statements. It returns
my $column_type = $column_obj->type;
my $nullable = $column_obj->null;
+ utf8::upgrade($value);
+
warn " $table.$column: $value ($column_type".
( $nullable ? ' NULL' : ' NOT NULL' ).
")\n" if $DEBUG > 2;
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'
)
{
- 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);
}
=cut
-sub str2time_sql {
+sub str2time_sql {
my $driver = shift || driver_name;
return 'UNIX_TIMESTAMP(' if $driver =~ /^mysql/i;
=cut
-sub str2time_sql_closing {
+sub str2time_sql_closing {
my $driver = shift || driver_name;
return ' )::INTEGER ' if $driver =~ /^Pg/i;
}
+=item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
+
+Returns the items concatenated based on database type, using "CONCAT()" for
+mysql and " || " for Pg and other databases.
+
+You can pass an optional driver name such as "Pg", "mysql" or
+$dbh->{Driver}->{Name} to return a function for that database instead of
+the current database.
+
+=cut
+
+sub concat_sql {
+ my $driver = ref($_[0]) ? driver_name : shift;
+ my $items = shift;
+
+ if ( $driver =~ /^mysql/i ) {
+ 'CONCAT('. join(',', @$items). ')';
+ } else {
+ join('||', @$items);
+ }
+
+}
+
+=item group_concat_sql COLUMN, DELIMITER
+
+Returns an SQL expression to concatenate an aggregate column, using
+GROUP_CONCAT() for mysql and array_to_string() and array_agg() for Pg.
+
+=cut
+
+sub group_concat_sql {
+ my ($col, $delim) = @_;
+ $delim = dbh->quote($delim);
+ if ( driver_name() =~ /^mysql/i ) {
+ # DISTINCT(foo) is valid as $col
+ return "GROUP_CONCAT($col SEPARATOR $delim)";
+ } else {
+ return "array_to_string(array_agg($col), $delim)";
+ }
+}
+
+=item midnight_sql DATE
+
+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
+
+sub midnight_sql {
+ my $driver = driver_name;
+ my $expr = shift;
+ if ( $driver =~ /^mysql/i ) {
+ "UNIX_TIMESTAMP(DATE(FROM_UNIXTIME($expr)))";
+ }
+ else {
+ "EXTRACT( EPOCH FROM DATE(TO_TIMESTAMP($expr)) )";
+ }
+}
+
=back
=head1 BUGS
=cut
1;
-
projects / freeside.git / blobdiff