use charnames ':full';
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 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 Email::Valid;
use FS::part_virtual_field;
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;
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'));
$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;
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}='';
}
#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
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;
#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 ) {
# 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') {
- 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;
push @statement, $statement;
warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
-
+
foreach my $field (
grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
# 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') {
- 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;
$alias_main ||= $table;
## could be optimized more for readability
- return (
+ return (
map {
my $op = '=';
}
} @{ $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;
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 ) : ();
$self->setfield($field,$value);
} else {
$self->getfield($field);
- }
+ }
}
# efficient (also, old, doesn't support FK stuff)
# $_[0]->setfield($field, $_[1]);
# } else {
# $_[0]->getfield($field);
-# }
+# }
#}
# get_fk_method(TABLE, FIELD)
my($self) = @_;
confess $self. ' -> hash: Hash attribute is undefined'
unless defined($self->{'Hash'});
- %{ $self->{'Hash'} };
+ %{ $self->{'Hash'} };
}
=item hashref
}
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') {
- 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;
$statement .= 'DEFAULT VALUES';
} else {
-
+
if ( $use_placeholders ) {
@bind_values = map $self->getfield($_), @real_fields;
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?)";
}
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});
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;
-
+
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 ( 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;
#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) : '' ).
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 ',
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';
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});
=cut
-sub check {
+sub check {
my $self = shift;
foreach my $field ($self->virtual_fields) {
my $error = $self->ut_textn($field);
=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
}
+=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
=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".
my %formats = %{ $opt->{formats} };
warn Dumper($param) if $DEBUG;
-
+
my $files = $param->{'uploaded_files'}
or die "No files provided.\n";
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 {
foreach my $field ( @fields ) {
my $value = shift @columns;
-
+
if ( ref($field) eq 'CODE' ) {
#&{$field}(\%hash, $value);
push @later, $field, $value;
=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
+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]
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);
'';
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
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->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.
$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);
'';
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)));
}
: '';
}
+=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_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).
}
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 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
=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
=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
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',
});
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'
)
{
- dbh->quote($value, { pg_type => PG_BYTEA() });
+ 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 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
=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
=cut
1;
-
projects / freeside.git / blobdiff