X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=d82924adfea7cd869087209ff0d542d49f8bfd03;hb=f13afe5e228a220311557e1ca6dacbf847c26baf;hp=f8711d021eda78ad2c06a63af2ca34b33653c020;hpb=9509e5bfb7f9331303153cac24d7bfecbe2ea9f1;p=freeside.git diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index f8711d021..d82924adf 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -9,15 +9,13 @@ use Carp qw(carp cluck croak confess); use File::CounterFile; use Locale::Country; use DBI qw(:sql_types); -use DBIx::DBSchema 0.25; -#use DBIx::DBSchema 0.33; #when check for ->can('unique_singles') is sub insert - #is removed +use DBIx::DBSchema 0.33; use FS::UID qw(dbh getotaker datasrc driver_name); use FS::CurrentUser; use FS::Schema qw(dbdef); use FS::SearchCache; use FS::Msgcat qw(gettext); -use FS::Conf; +#use FS::Conf; #dependency loop bs, in install_callback below instead use FS::part_virtual_field; @@ -26,7 +24,7 @@ use Tie::IxHash; @ISA = qw(Exporter); #export dbdef for now... everything else expects to find it here -@EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef jsearch); +@EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef jsearch str2time_sql); $DEBUG = 0; $me = '[FS::Record]'; @@ -40,6 +38,8 @@ my $rsa_encrypt; my $rsa_decrypt; FS::UID->install_callback( sub { + eval "use FS::Conf;"; + die $@ if $@; $conf = new FS::Conf; $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc; } ); @@ -216,6 +216,7 @@ The preferred usage is to pass a hash reference of named parameters: 'order_by' => 'ORDER BY something', #'cache_obj' => '', #optional 'addl_from' => 'LEFT JOIN othtable USING ( field )', + 'debug' => 1, } ); @@ -237,6 +238,7 @@ fine in the common case where there are only two parameters: sub qsearch { my($stable, $record, $select, $extra_sql, $order_by, $cache, $addl_from ); + my $debug = ''; if ( ref($_[0]) ) { #hashref for now, eventually maybe accept a list too my $opt = shift; $stable = $opt->{'table'} or die "table name is required"; @@ -246,6 +248,7 @@ sub qsearch { $order_by = $opt->{'order_by'} || ''; $cache = $opt->{'cache_obj'} || ''; $addl_from = $opt->{'addl_from'} || ''; + $debug = $opt->{'debug'} || ''; } else { ($stable, $record, $select, $extra_sql, $cache, $addl_from ) = @_; $select ||= '*'; @@ -276,97 +279,15 @@ sub qsearch { $statement .= " $addl_from" if $addl_from; if ( @real_fields or @virtual_fields ) { $statement .= ' WHERE '. join(' AND ', - ( map { - - my $op = '='; - my $column = $_; - if ( ref($record->{$_}) ) { - $op = $record->{$_}{'op'} if $record->{$_}{'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->{$_} = $record->{$_}{'value'} - } - - if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) { - if ( $op eq '=' ) { - if ( driver_name eq 'Pg' ) { - my $type = dbdef->table($table)->column($column)->type; - if ( $type =~ /(int|(big)?serial)/i ) { - qq-( $column IS NULL )-; - } else { - qq-( $column IS NULL OR $column = '' )-; - } - } else { - qq-( $column IS NULL OR $column = "" )-; - } - } elsif ( $op eq '!=' ) { - if ( driver_name eq 'Pg' ) { - my $type = dbdef->table($table)->column($column)->type; - if ( $type =~ /(int|(big)?serial)/i ) { - qq-( $column IS NOT NULL )-; - } else { - qq-( $column IS NOT NULL AND $column != '' )-; - } - } else { - qq-( $column IS NOT NULL AND $column != "" )-; - } - } else { - if ( driver_name eq 'Pg' ) { - qq-( $column $op '' )-; - } else { - qq-( $column $op "" )-; - } - } - } else { - "$column $op ?"; - } - } @real_fields ), - ( 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'}; - } - - # ... 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') ) - - my $value = $record->{$_}; - - my $subq; - - $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; - - } @virtual_fields ) ); - + get_real_fields($table, $record, \@real_fields) , + get_virtual_fields($table, $pkey, $record, \@virtual_fields), + ); } $statement .= " $extra_sql" if defined($extra_sql); $statement .= " $order_by" if defined($order_by); - warn "[debug]$me $statement\n" if $DEBUG > 1; + warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug; my $sth = $dbh->prepare($statement) or croak "$dbh->errstr doing $statement"; @@ -379,6 +300,14 @@ sub qsearch { && dbdef->table($table)->column($field)->type =~ /(int|(big)?serial)/i ) { $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_INTEGER } ); + }elsif ( $record->{$field} =~ /^[+-]?\d+(\.\d+)?$/ + && dbdef->table($table)->column($field)->type =~ /(numeric)/i + ) { + $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_FLOAT } ); + }elsif ( $record->{$field} =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/ + && dbdef->table($table)->column($field)->type =~ /(float4)/i + ) { + $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_FLOAT } ); } else { $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_VARCHAR } ); } @@ -473,6 +402,110 @@ sub qsearch { return @return; } +## makes this easier to read + +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'}; + } + + # ... 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') ) + + my $value = $record->{$_}; + + my $subq; + + $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; + + } @{ $virtual_fields } ) ; +} + +sub get_real_fields { + my $table = shift; + 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 { + + my $op = '='; + my $column = $_; + if ( ref($record->{$_}) ) { + $op = $record->{$_}{'op'} if $record->{$_}{'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->{$_} = $record->{$_}{'value'} + } + + if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) { + if ( $op eq '=' ) { + if ( driver_name eq 'Pg' ) { + my $type = dbdef->table($table)->column($column)->type; + if ( $type =~ /(int|(big)?serial)/i ) { + qq-( $column IS NULL )-; + } else { + qq-( $column IS NULL OR $column = '' )-; + } + } else { + qq-( $column IS NULL OR $column = "" )-; + } + } elsif ( $op eq '!=' ) { + if ( driver_name eq 'Pg' ) { + my $type = dbdef->table($table)->column($column)->type; + if ( $type =~ /(int|(big)?serial)/i ) { + qq-( $column IS NOT NULL )-; + } else { + qq-( $column IS NOT NULL AND $column != '' )-; + } + } else { + qq-( $column IS NOT NULL AND $column != "" )-; + } + } else { + if ( driver_name eq 'Pg' ) { + qq-( $column $op '' )-; + } else { + qq-( $column $op "" )-; + } + } + } else { + "$column $op ?"; + } + } @{ $real_fields } ); +} + =item by_key PRIMARY_KEY_VALUE This is a class method that returns the record with the given primary key @@ -730,10 +763,7 @@ sub insert { #single-field unique keys are given a value if false #(like MySQL's AUTO_INCREMENT or Pg SERIAL) - foreach ( $self->dbdef_table->can('unique_singles') - ? $self->dbdef_table->unique_singles - : $self->dbdef_table->unique->singles - ) { + foreach ( $self->dbdef_table->unique_singles) { $self->unique($_) unless $self->getfield($_); } @@ -760,7 +790,6 @@ sub insert { # Encrypt before the database - my $conf = new FS::Conf; if ($conf->exists('encryption') && defined(eval '@FS::'. $table . '::encrypted_fields')) { foreach my $field (eval '@FS::'. $table . '::encrypted_fields') { $self->{'saved'} = $self->getfield($field); @@ -1038,7 +1067,6 @@ sub replace { return $error if $error; # Encrypt for replace - my $conf = new FS::Conf; my $saved = {}; if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . '::encrypted_fields')) { foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') { @@ -1258,7 +1286,6 @@ sub _h_statement { # If we're encrypting then don't ever store the payinfo or CVV2 in the history.... # You can see if it changed by the paymask... - my $conf = new FS::Conf; if ($conf->exists('encryption') ) { @fields = grep $_ ne 'payinfo' && $_ ne 'cvv2', @fields; } @@ -1323,10 +1350,10 @@ null. If there is an error, returns the error, otherwise returns false. sub ut_float { my($self,$field)=@_ ; - ($self->getfield($field) =~ /^(\d+\.\d+)$/ || - $self->getfield($field) =~ /^(\d+)$/ || - $self->getfield($field) =~ /^(\d+\.\d+e\d+)$/ || - $self->getfield($field) =~ /^(\d+e\d+)$/) + ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ || + $self->getfield($field) =~ /^\s*(\d+)\s*$/ || + $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ || + $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/) or return "Illegal or empty (float) $field: ". $self->getfield($field); $self->setfield($field,$1); ''; @@ -1359,10 +1386,10 @@ false. sub ut_sfloat { my($self,$field)=@_ ; - ($self->getfield($field) =~ /^(-?\d+\.\d+)$/ || - $self->getfield($field) =~ /^(-?\d+)$/ || - $self->getfield($field) =~ /^(-?\d+\.\d+[eE]-?\d+)$/ || - $self->getfield($field) =~ /^(-?\d+[eE]-?\d+)$/) + ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ || + $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ || + $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ || + $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/) or return "Illegal or empty (float) $field: ". $self->getfield($field); $self->setfield($field,$1); ''; @@ -1393,7 +1420,7 @@ returns the error, otherwise returns false. sub ut_snumber { my($self, $field) = @_; - $self->getfield($field) =~ /^(-?)\s*(\d+)$/ + $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/ or return "Illegal or empty (numeric) $field: ". $self->getfield($field); $self->setfield($field, "$1$2"); ''; @@ -1408,7 +1435,7 @@ returns the error, otherwise returns false. sub ut_snumbern { my($self, $field) = @_; - $self->getfield($field) =~ /^(-?)\s*(\d*)$/ + $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/ or return "Illegal (numeric) $field: ". $self->getfield($field); if ($1) { return "Illegal (numeric) $field: ". $self->getfield($field) @@ -1427,7 +1454,7 @@ is an error, returns the error, otherwise returns false. sub ut_number { my($self,$field)=@_; - $self->getfield($field) =~ /^(\d+)$/ + $self->getfield($field) =~ /^\s*(\d+)\s*$/ or return "Illegal or empty (numeric) $field: ". $self->getfield($field); $self->setfield($field,$1); ''; @@ -1442,7 +1469,7 @@ an error, returns the error, otherwise returns false. sub ut_numbern { my($self,$field)=@_; - $self->getfield($field) =~ /^(\d*)$/ + $self->getfield($field) =~ /^\s*(\d*)\s*$/ or return "Illegal (numeric) $field: ". $self->getfield($field); $self->setfield($field,$1); ''; @@ -1458,7 +1485,7 @@ is an error, returns the error, otherwise returns false. sub ut_money { my($self,$field)=@_; $self->setfield($field, 0) if $self->getfield($field) eq ''; - $self->getfield($field) =~ /^(\-)? ?(\d*)(\.\d{2})?$/ + $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); @@ -1535,6 +1562,20 @@ sub ut_alphan { ''; } +=item ut_alpha_lower COLUMN + +Check/untaint lowercase alphanumeric strings (no spaces). May not be null. If +there is an error, returns the error, otherwise returns false. + +=cut + +sub ut_alpha_lower { + my($self,$field)=@_; + $self->getfield($field) =~ /[[:upper:]]/ + and return "Uppercase characters are not permitted in $field"; + $self->ut_alpha($field); +} + =item ut_phonen COLUMN [ COUNTRY ] Check/untaint phone numbers. May be null. If there is an error, returns @@ -1881,7 +1922,7 @@ sub ut_agentnum_acl { if ( $self->$field() ) { - return "Access deined" + return "Access denied" unless $curuser->agentnum($self->$field()); } else { @@ -1945,8 +1986,6 @@ sub fields { return (real_fields($table), $something->virtual_fields()); } -=back - =item pvf FIELD_NAME Returns the FS::part_virtual_field object corresponding to a field in the @@ -1964,57 +2003,6 @@ sub pvf { '' } -=head1 SUBROUTINES - -=over 4 - -=item real_fields [ TABLE ] - -Returns a list of the real columns in the specified table. Called only by -fields() and other subroutines elsewhere in FS::Record. - -=cut - -sub real_fields { - my $table = shift; - - my($table_obj) = dbdef->table($table); - confess "Unknown table $table" unless $table_obj; - $table_obj->columns; -} - -=item _quote VALUE, TABLE, COLUMN - -This is an internal function used to construct SQL statements. It returns -VALUE DBI-quoted (see L) unless VALUE is a number and the column -type (see L) does not end in `char' or `binary'. - -=cut - -sub _quote { - my($value, $table, $column) = @_; - my $column_obj = dbdef->table($table)->column($column); - my $column_type = $column_obj->type; - my $nullable = $column_obj->null; - - warn " $table.$column: $value ($column_type". - ( $nullable ? ' NULL' : ' NOT NULL' ). - ")\n" if $DEBUG > 2; - - if ( $value eq '' && $nullable ) { - 'NULL' - } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) { - cluck "WARNING: Attempting to set non-null integer $table.$column null; ". - "using 0 instead"; - 0; - } elsif ( $value =~ /^\d+(\.\d+)?$/ && - ! $column_type =~ /(char|binary|text)$/i ) { - $value; - } else { - dbh->quote($value); - } -} - =item vfieldpart_hashref TABLE Returns a hashref of virtual field names and vfieldparts applicable to the given @@ -2038,32 +2026,6 @@ sub vfieldpart_hashref { } - -=item hfields TABLE - -This is deprecated. Don't use it. - -It returns a hash-type list with the fields of this record's table set true. - -=cut - -sub hfields { - carp "warning: hfields is deprecated"; - my($table)=@_; - my(%hash); - foreach (fields($table)) { - $hash{$_}=1; - } - \%hash; -} - -sub _dump { - my($self)=@_; - join("\n", map { - "$_: ". $self->getfield($_). "|" - } (fields($self->table)) ); -} - =item encrypt($value) Encrypts the credit card using a combination of PK to encrypt and uuencode to armour. @@ -2074,12 +2036,10 @@ You should generally not have to worry about calling this, as the system handles =cut - sub encrypt { my ($self, $value) = @_; my $encrypted; - my $conf = new FS::Conf; if ($conf->exists('encryption')) { if ($self->is_encrypted($value)) { # Return the original value if it isn't plaintext. @@ -2128,7 +2088,6 @@ You should generally not have to worry about calling this, as the system handles sub decrypt { my ($self,$value) = @_; my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted. - my $conf = new FS::Conf; if ($conf->exists('encryption') && $self->is_encrypted($value)) { $self->loadRSA; if (ref($rsa_decrypt) =~ /::RSA/) { @@ -2145,7 +2104,6 @@ sub loadRSA { #Initialize the Module $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default - my $conf = new FS::Conf; if ($conf->exists('encryptionmodule') && $conf->config_binary('encryptionmodule') ne '') { $rsa_module = $conf->config('encryptionmodule'); } @@ -2167,6 +2125,121 @@ sub loadRSA { } } +=item h_search ACTION + +Given an ACTION, either "insert", or "delete", returns the appropriate history +record corresponding to this record, if any. + +=cut + +sub h_search { + my( $self, $action ) = @_; + + my $table = $self->table; + $table =~ s/^h_//; + + my $primary_key = dbdef->table($table)->primary_key; + + qsearchs({ + 'table' => "h_$table", + 'hashref' => { $primary_key => $self->$primary_key(), + 'history_action' => $action, + }, + }); + +} + +=item h_date ACTION + +Given an ACTION, either "insert", or "delete", returns the timestamp of the +appropriate history record corresponding to this record, if any. + +=cut + +sub h_date { + my($self, $action) = @_; + my $h = $self->h_search($action); + $h ? $h->history_date : ''; +} + +=back + +=head1 SUBROUTINES + +=over 4 + +=item real_fields [ TABLE ] + +Returns a list of the real columns in the specified table. Called only by +fields() and other subroutines elsewhere in FS::Record. + +=cut + +sub real_fields { + my $table = shift; + + my($table_obj) = dbdef->table($table); + confess "Unknown table $table" unless $table_obj; + $table_obj->columns; +} + +=item _quote VALUE, TABLE, COLUMN + +This is an internal function used to construct SQL statements. It returns +VALUE DBI-quoted (see L) unless VALUE is a number and the column +type (see L) does not end in `char' or `binary'. + +=cut + +sub _quote { + my($value, $table, $column) = @_; + my $column_obj = dbdef->table($table)->column($column); + my $column_type = $column_obj->type; + my $nullable = $column_obj->null; + + warn " $table.$column: $value ($column_type". + ( $nullable ? ' NULL' : ' NOT NULL' ). + ")\n" if $DEBUG > 2; + + if ( $value eq '' && $nullable ) { + 'NULL' + } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) { + cluck "WARNING: Attempting to set non-null integer $table.$column null; ". + "using 0 instead"; + 0; + } elsif ( $value =~ /^\d+(\.\d+)?$/ && + ! $column_type =~ /(char|binary|text)$/i ) { + $value; + } else { + dbh->quote($value); + } +} + +=item hfields TABLE + +This is deprecated. Don't use it. + +It returns a hash-type list with the fields of this record's table set true. + +=cut + +sub hfields { + carp "warning: hfields is deprecated"; + my($table)=@_; + my(%hash); + foreach (fields($table)) { + $hash{$_}=1; + } + \%hash; +} + +sub _dump { + my($self)=@_; + join("\n", map { + "$_: ". $self->getfield($_). "|" + } (fields($self->table)) ); +} + sub DESTROY { return; } #sub DESTROY { @@ -2180,6 +2253,49 @@ sub DESTROY { return; } # return ! eval { join('',@_), kill 0; 1; }; # } +=item str2time_sql [ DRIVER_NAME ] + +Returns a function to convert to unix time based on database type, such as +"EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql. See +the str2time_sql_closing method to return a closing string rather than just +using a closing parenthesis as previously suggested. + +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 str2time_sql { + my $driver = shift || driver_name; + + return 'UNIX_TIMESTAMP(' if $driver =~ /^mysql/i; + return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i; + + warn "warning: unknown database type $driver; guessing how to convert ". + "dates to UNIX timestamps"; + return 'EXTRACT(EPOCH FROM '; + +} + +=item str2time_sql_closing [ DRIVER_NAME ] + +Returns the closing suffix of a function to convert to unix time based on +database type, such as ")::integer" for Pg or ")" for mysql. + +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 str2time_sql_closing { + my $driver = shift || driver_name; + + return ' )::INTEGER ' if $driver =~ /^Pg/i; + return ' ) '; +} + =back =head1 BUGS