X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=022f7cdfb001db50631069fab6da397a2009fa78;hb=57258cd385f8b61abf430c3a448fdaf4e1831494;hp=7f35265ecab5bd7a3bfb4faddf4aff3cb1bb31d0;hpb=067e229cc5476d16238f71da7606c717845bf23b;p=freeside.git diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index 7f35265ec..022f7cdfb 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -3,11 +3,16 @@ package FS::Record; use strict; use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG $conf $me - %virtual_fields_cache $nowarn_identical $no_update_diff ); + %virtual_fields_cache + $nowarn_identical $no_update_diff $no_check_foreign + ); use Exporter; use Carp qw(carp cluck croak confess); +use Scalar::Util qw( blessed ); use File::CounterFile; use Locale::Country; +use Text::CSV_XS; +use File::Slurp qw( slurp ); use DBI qw(:sql_types); use DBIx::DBSchema 0.33; use FS::UID qw(dbh getotaker datasrc driver_name); @@ -15,7 +20,7 @@ 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; @@ -24,13 +29,15 @@ 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 str2time_sql_closing ); $DEBUG = 0; $me = '[FS::Record]'; $nowarn_identical = 0; $no_update_diff = 0; +$no_check_foreign = 0; my $rsa_module; my $rsa_loaded; @@ -38,7 +45,9 @@ my $rsa_encrypt; my $rsa_decrypt; FS::UID->install_callback( sub { - $conf = new FS::Conf; + eval "use FS::Conf;"; + die $@ if $@; + $conf = FS::Conf->new; $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc; } ); @@ -234,6 +243,8 @@ fine in the common case where there are only two parameters: =cut +my %TYPE = (); #for debugging + sub qsearch { my($stable, $record, $select, $extra_sql, $order_by, $cache, $addl_from ); my $debug = ''; @@ -294,13 +305,33 @@ sub qsearch { foreach my $field ( grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields ) { - if ( $record->{$field} =~ /^\d+(\.\d+)?$/ - && dbdef->table($table)->column($field)->type =~ /(int|(big)?serial)/i - ) { - $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_INTEGER } ); - } else { - $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_VARCHAR } ); + + my $value = $record->{$field}; + $value = $value->{'value'} if ref($value); + my $type = dbdef->table($table)->column($field)->type; + + my $TYPE = SQL_VARCHAR; + if ( $type =~ /(int|(big)?serial)/i && $value =~ /^\d+(\.\d+)?$/ ) { + $TYPE = SQL_INTEGER; + + #DBD::Pg 1.49: Cannot bind ... unknown sql_type 6 with SQL_FLOAT + } elsif ( ( $type =~ /(numeric)/i && $value =~ /^[+-]?\d+(\.\d+)?$/) + || ( $type =~ /(real|float4)/i + && $value =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/ + ) + ) { + $TYPE = SQL_DECIMAL; + } + + 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"; } + + $sth->bind_param($bind++, $value, { TYPE => $TYPE } ); + } # $sth->execute( map $record->{$_}, @@ -654,11 +685,11 @@ sub AUTOLOAD { $field =~ s/.*://; if ( defined($value) ) { confess "errant AUTOLOAD $field for $self (arg $value)" - unless ref($self) && $self->can('setfield'); + unless blessed($self) && $self->can('setfield'); $self->setfield($field,$value); } else { confess "errant AUTOLOAD $field for $self (no args)" - unless ref($self) && $self->can('getfield'); + unless blessed($self) && $self->can('getfield'); $self->getfield($field); } } @@ -777,18 +808,18 @@ sub insert { } my $table = $self->table; - # Encrypt before the database - my $conf = new FS::Conf; - if ($conf->exists('encryption') && defined(eval '@FS::'. $table . '::encrypted_fields')) { + if ( defined(eval '@FS::'. $table . '::encrypted_fields') + && scalar( eval '@FS::'. $table . '::encrypted_fields') + && $conf->exists('encryption') + ) { foreach my $field (eval '@FS::'. $table . '::encrypted_fields') { $self->{'saved'} = $self->getfield($field); $self->setfield($field, $self->encrypt($self->getfield($field))); } } - #false laziness w/delete my @real_fields = grep { defined($self->getfield($_)) && $self->getfield($_) ne "" } @@ -1058,7 +1089,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') { @@ -1266,6 +1296,194 @@ sub check { ''; } +=item batch_import PARAM_HASHREF + +Class method for batch imports. Available params: + +=over 4 + +=item job + +FS::queue object, will be updated with progress + +=back + +=cut + +use Storable qw(thaw); +use Data::Dumper; +use MIME::Base64; +sub process_batch_import { + my($job, $opt) = ( shift, shift ); + + my $table = $opt->{table}; + my @pass_params = @{ $opt->{params} }; + my %formats = %{ $opt->{formats} }; + + my $param = thaw(decode_base64(shift)); + warn Dumper($param) if $DEBUG; + + my $files = $param->{'uploaded_files'} + or die "No files provided.\n"; + + my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files; + + my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/'; + my $file = $dir. $files{'file'}; + + my $type; + if ( $file =~ /\.(\w+)$/i ) { + $type = lc($1); + } else { + #or error out??? + warn "can't parse file type from filename $file; defaulting to CSV"; + $type = 'csv'; + } + + my $error = + FS::Record::batch_import( { + table => $table, + formats => \%formats, + job => $job, + file => $file, + type => $type, + format => $param->{format}, + params => { map { $_ => $param->{$_} } @pass_params }, + } ); + + unlink $file; + + die "$error\n" if $error; +} + +sub batch_import { + my $param = shift; + + my $table = $param->{table}; + my $formats = $param->{formats}; + my $params = $param->{params}; + + my $job = $param->{job}; + + my $filename = $param->{file}; + my $type = $param->{type} || 'csv'; + + my $format = $param->{'format'}; + + die "unknown format $format" unless exists $formats->{ $format }; + my @fields = @{ $formats->{ $format } }; + + my $count; + my $parser; + my @buffer = (); + if ( $type eq 'csv' ) { + + $parser = new Text::CSV_XS; + + @buffer = split(/\r?\n/, slurp($filename) ); + $count = scalar(@buffer); + + } elsif ( $type eq 'xls' ) { + + eval "use Spreadsheet::ParseExcel;"; + die $@ if $@; + + my $excel = new Spreadsheet::ParseExcel::Workbook->Parse($filename); + $parser = $excel->{Worksheet}[0]; #first sheet + + $count = $parser->{MaxRow} || $parser->{MinRow}; + $count++; + + } else { + die "Unknown file type $type\n"; + } + + #my $columns; + + local $SIG{HUP} = 'IGNORE'; + local $SIG{INT} = 'IGNORE'; + local $SIG{QUIT} = 'IGNORE'; + local $SIG{TERM} = 'IGNORE'; + local $SIG{TSTP} = 'IGNORE'; + local $SIG{PIPE} = 'IGNORE'; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + my $line; + my $row = 0; + my( $last, $min_sec ) = ( time, 5 ); #progressbar foo + while (1) { + + my @columns = (); + if ( $type eq 'csv' ) { + + last unless scalar(@buffer); + $line = shift(@buffer); + + $parser->parse($line) or do { + $dbh->rollback if $oldAutoCommit; + return "can't parse: ". $parser->error_input(); + }; + @columns = $parser->fields(); + + } elsif ( $type eq 'xls' ) { + + last if $row > ($parser->{MaxRow} || $parser->{MinRow}); + + my @row = @{ $parser->{Cells}[$row] }; + @columns = map $_->{Val}, @row; + + #my $z = 'A'; + #warn $z++. ": $_\n" for @columns; + + } else { + die "Unknown file type $type\n"; + } + + my %hash = %$params; + + foreach my $field ( @fields ) { + + my $value = shift @columns; + + if ( ref($field) eq 'CODE' ) { + &{$field}(\%hash, $value); + } else { + $hash{$field} = $value if length($value); + } + + } + + my $class = "FS::$table"; + + my $record = $class->new( \%hash ); + + my $error = $record->insert; + + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "can't insert record". ( $line ? " for $line" : '' ). ": $error"; + } + + $row++; + + if ( $job && time - $min_sec > $last ) { #progress bar + $job->update_statustext( int(100 * $row / $count) ); + $last = time; + } + + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit;; + + return "Empty file!" unless $row; + + ''; #no error + +} + sub _h_statement { my( $self, $action, $time ) = @_; @@ -1278,8 +1496,7 @@ 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') ) { + if ($conf && $conf->exists('encryption') ) { @fields = grep $_ ne 'payinfo' && $_ ne 'cvv2', @fields; } my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields; @@ -1343,10 +1560,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); ''; @@ -1379,10 +1596,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); ''; @@ -1413,7 +1630,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"); ''; @@ -1428,7 +1645,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) @@ -1447,7 +1664,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); ''; @@ -1462,7 +1679,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); ''; @@ -1478,7 +1695,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); @@ -1555,6 +1772,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 @@ -1573,6 +1804,8 @@ sub ut_phonen { $self->setfield($field,''); } elsif ( $country eq 'US' || $country eq 'CA' ) { $phonen =~ s/\D//g; + $phonen = $conf->config('cust_main-default_areacode').$phonen + if length($phonen)==7 && $conf->config('cust_main-default_areacode'); $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/ or return gettext('illegal_phone'). " $field: ". $self->getfield($field); $phonen = "$1-$2-$3"; @@ -1865,6 +2098,7 @@ on the column first. sub ut_foreign_key { my( $self, $field, $table, $foreign ) = @_; + return '' if $no_check_foreign; qsearchs($table, { $foreign => $self->getfield($field) }) or return "Can't find ". $self->table. ".$field ". $self->getfield($field). " in $table.$foreign"; @@ -1901,7 +2135,7 @@ sub ut_agentnum_acl { if ( $self->$field() ) { - return "Access deined" + return "Access denied" unless $curuser->agentnum($self->$field()); } else { @@ -1965,8 +2199,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 @@ -1984,57 +2216,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 @@ -2058,32 +2239,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. @@ -2094,12 +2249,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. @@ -2148,7 +2301,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/) { @@ -2165,7 +2317,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'); } @@ -2187,6 +2338,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 { @@ -2200,6 +2466,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