X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=be29b5c8a73a6caeb6989a75e3c9353cca3bbb91;hb=27af526f59996d1f1cb8f4181d4e320020c98062;hp=4b6684d8e73ebe11183818ca7295a10e8a83e6f7;hpb=cb3519647ad9a022e14e596e28a5a5eed6afae49;p=freeside.git diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index 4b6684d8e..be29b5c8a 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -2,9 +2,10 @@ package FS::Record; use strict; use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG - $conf $me + $conf $conf_encryption $me %virtual_fields_cache - $nowarn_identical $no_update_diff $no_check_foreign + $nowarn_identical $nowarn_classload + $no_update_diff $no_check_foreign ); use Exporter; use Carp qw(carp cluck croak confess); @@ -36,6 +37,7 @@ $DEBUG = 0; $me = '[FS::Record]'; $nowarn_identical = 0; +$nowarn_classload = 0; $no_update_diff = 0; $no_check_foreign = 0; @@ -44,10 +46,13 @@ my $rsa_loaded; my $rsa_encrypt; my $rsa_decrypt; +$conf = ''; +$conf_encryption = ''; FS::UID->install_callback( sub { eval "use FS::Conf;"; die $@ if $@; $conf = FS::Conf->new; + $conf_encryption = $conf->exists('encryption'); $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc; } ); @@ -149,7 +154,8 @@ sub new { unless ( defined ( $self->table ) ) { $self->{'Table'} = shift; - carp "warning: FS::Record::new called with table name ". $self->{'Table'}; + carp "warning: FS::Record::new called with table name ". $self->{'Table'} + unless $nowarn_classload; } $self->{'Hash'} = shift; @@ -209,23 +215,24 @@ objects. The preferred usage is to pass a hash reference of named parameters: - my @records = qsearch( { - 'table' => 'table_name', - 'hashref' => { 'field' => 'value' - 'field' => { 'op' => '<', - 'value' => '420', - }, - }, - - #these are optional... - 'select' => '*', - 'extra_sql' => 'AND field ', - 'order_by' => 'ORDER BY something', - #'cache_obj' => '', #optional - 'addl_from' => 'LEFT JOIN othtable USING ( field )', - 'debug' => 1, - } - ); + @records = qsearch( { + 'table' => 'table_name', + 'hashref' => { 'field' => 'value' + 'field' => { 'op' => '<', + 'value' => '420', + }, + }, + + #these are optional... + 'select' => '*', + 'extra_sql' => 'AND field = ? AND intfield = ?', + 'extra_param' => [ 'value', [ 5, 'int' ] ], + 'order_by' => 'ORDER BY something', + #'cache_obj' => '', #optional + 'addl_from' => 'LEFT JOIN othtable USING ( field )', + 'debug' => 1, + } + ); Much code still uses old-style positional parameters, this is also probably fine in the common case where there are only two parameters: @@ -245,19 +252,31 @@ fine in the common case where there are only two parameters: my %TYPE = (); #for debugging +sub _is_fs_float { + my ($type, $value) = @_; + if ( ( $type =~ /(numeric)/i && $value =~ /^[+-]?\d+(\.\d+)?$/ ) || + ( $type =~ /(real|float4)/i && $value =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/) + ) { + return 1; + } + ''; +} + sub qsearch { - my($stable, $record, $select, $extra_sql, $order_by, $cache, $addl_from ); + my($stable, $record, $cache ); + my( $select, $extra_sql, $extra_param, $order_by, $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"; - $record = $opt->{'hashref'} || {}; - $select = $opt->{'select'} || '*'; - $extra_sql = $opt->{'extra_sql'} || ''; - $order_by = $opt->{'order_by'} || ''; - $cache = $opt->{'cache_obj'} || ''; - $addl_from = $opt->{'addl_from'} || ''; - $debug = $opt->{'debug'} || ''; + $stable = $opt->{'table'} or die "table name is required"; + $record = $opt->{'hashref'} || {}; + $select = $opt->{'select'} || '*'; + $extra_sql = $opt->{'extra_sql'} || ''; + $extra_param = $opt->{'extra_param'} || []; + $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 ||= '*'; @@ -280,7 +299,8 @@ sub qsearch { 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"; + cluck "warning: FS::$table not loaded; virtual fields not searchable" + unless $nowarn_classload; @virtual_fields = (); } @@ -307,19 +327,18 @@ sub qsearch { ) { 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 $TYPE = SQL_VARCHAR; - if ( $type =~ /(int|(big)?serial)/i && $value =~ /^\d+(\.\d+)?$/ ) { + if ( $type =~ /(big)?(int|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+)?/ - ) - ) { + #fixed by DBD::Pg 2.11.8 + #can change back to SQL_FLOAT in early-mid 2010, once everyone's upgraded + } elsif ( _is_fs_float( $type, $value ) ) { $TYPE = SQL_DECIMAL; } @@ -330,8 +349,30 @@ sub qsearch { warn " bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n"; } - $sth->bind_param($bind++, $value, { TYPE => $TYPE } ); + #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 + #if ($TYPE eq SQL_DECIMAL && $op eq 'APPROX=' ) { + # # these values are arbitrary; better (faster?) ones welcome + # $sth->bind_param($bind++, $value*1.00001, { TYPE => $TYPE } ); + # $sth->bind_param($bind++, $value*.99999, { TYPE => $TYPE } ); + #} else { + $sth->bind_param($bind++, $value, { TYPE => $TYPE } ); + #} + + } + foreach my $param ( @$extra_param ) { + my $TYPE = SQL_VARCHAR; + my $value = $param; + if ( ref($param) ) { + $value = $param->[0]; + my $type = $param->[1]; + if ( $type =~ /(big)?(int|serial)/i && $value =~ /^\d+(\.\d+)?$/ ) { + $TYPE = SQL_INTEGER; + } # & DECIMAL? well, who cares for now + } + $sth->bind_param($bind++, $value, { TYPE => $TYPE } ); } # $sth->execute( map $record->{$_}, @@ -343,7 +384,8 @@ sub qsearch { if ( eval 'scalar(@FS::'. $table. '::ISA);' ) { @virtual_fields = "FS::$table"->virtual_fields; } else { - cluck "warning: FS::$table not loaded; virtual fields not returned either"; + cluck "warning: FS::$table not loaded; virtual fields not returned either" + unless $nowarn_classload; @virtual_fields = (); } @@ -403,10 +445,8 @@ sub qsearch { # Check for encrypted fields and decrypt them. ## only in the local copy, not the cached object - if ( $conf && $conf->exists('encryption') # $conf doesn't exist when doing - # the initial search for - # access_user - && eval 'defined(@FS::'. $table . '::encrypted_fields)') { + if ( $conf_encryption + && eval 'defined(@FS::'. $table . '::encrypted_fields)' ) { foreach my $record (@return) { foreach my $field (eval '@FS::'. $table . '::encrypted_fields') { # Set it directly... This may cause a problem in the future... @@ -415,7 +455,8 @@ sub qsearch { } } } else { - cluck "warning: FS::$table not loaded; returning FS::Record objects"; + cluck "warning: FS::$table not loaded; returning FS::Record objects" + unless $nowarn_classload; @return = map { FS::Record->new( $table, { %{$_} } ); } values(%result); @@ -480,6 +521,9 @@ sub get_real_fields { my $op = '='; my $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'}; #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg'; @@ -494,8 +538,7 @@ sub get_real_fields { 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 ) { + if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) { qq-( $column IS NULL )-; } else { qq-( $column IS NULL OR $column = '' )-; @@ -505,8 +548,7 @@ sub get_real_fields { } } elsif ( $op eq '!=' ) { if ( driver_name eq 'Pg' ) { - my $type = dbdef->table($table)->column($column)->type; - if ( $type =~ /(int|(big)?serial)/i ) { + if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) { qq-( $column IS NOT NULL )-; } else { qq-( $column IS NOT NULL AND $column != '' )-; @@ -521,6 +563,11 @@ sub get_real_fields { qq-( $column $op "" )-; } } + #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 >= ?" ); } else { "$column $op ?"; } @@ -766,6 +813,50 @@ sub select_for_update { } ); } +=item lock_table + +Locks this table with a database-driver specific lock method. This is used +as a mutex in order to do a duplicate search. + +For PostgreSQL, does "LOCK TABLE tablename IN SHARE ROW EXCLUSIVE MODE". + +For MySQL, does a SELECT FOR UPDATE on the duplicate_lock table. + +Errors are fatal; no useful return value. + +Note: To use this method for new tables other than svc_acct and svc_phone, +edit freeside-upgrade and add those tables to the duplicate_lock list. + +=cut + +sub lock_table { + my $self = shift; + my $table = $self->table; + + warn "$me locking $table table\n" if $DEBUG; + + if ( driver_name =~ /^Pg/i ) { + + dbh->do("LOCK TABLE $table IN SHARE ROW EXCLUSIVE MODE") + or die dbh->errstr; + + } elsif ( driver_name =~ /^mysql/i ) { + + dbh->do("SELECT * FROM duplicate_lock + WHERE lockname = '$table' + FOR UPDATE" + ) or die dbh->errstr; + + } else { + + die "unknown database ". driver_name. "; don't know how to lock table"; + + } + + warn "$me acquired $table table lock\n" if $DEBUG; + +} + =item insert Inserts this record to the database. If there is an error, returns the error, @@ -1296,18 +1387,76 @@ sub check { ''; } -=item batch_import PARAM_HASHREF +=item process_batch_import JOB OPTIONS_HASHREF PARAMS -Class method for batch imports. Available 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 job +=item table -FS::queue object, will be updated with progress +Table name (required). + +=item params + +Listref 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 + +Formats hashref. Keys are field names, values are listrefs that define the +format. + +Each listref value can be a column name or a code reference. Coderefs are run +with the row object, data and a FS::Conf object as the three parameters. +For example, this coderef does the same thing as using the "columnname" string: + + sub { + my( $record, $data, $conf ) = @_; + $record->columnname( $data ); + }, + +Coderefs are run after all "column name" fields are assigned. + +=item format_types + +Optional format hashref of types. Keys are field names, values are "csv", +"xls" or "fixedlength". Overrides automatic determination of file type +from extension. + +=item format_headers + +Optional format hashref of header lines. Keys are field names, values are 0 +for no header, 1 to ignore the first line, or to higher numbers to ignore that +number of lines. + +=item format_sep_chars + +Optional format hashref of CSV sep_chars. Keys are field names, values are the +CSV separation character. + +=item format_fixedlenth_formats + +Optional format hashref of fixed length format defintiions. Keys are field +names, values Parse::FixedLength listrefs of field definitions. + +=item default_csv + +Set true to default to CSV file type if the filename does not contain a +recognizable ".csv" or ".xls" extension (and type is not pre-specified by +format_types). =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". + =cut use Storable qw(thaw); @@ -1331,24 +1480,23 @@ sub process_batch_import { 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 }, + #class-static + table => $table, + formats => \%formats, + format_types => $opt->{format_types}, + format_headers => $opt->{format_headers}, + format_sep_chars => $opt->{format_sep_chars}, + format_fixedlength_formats => $opt->{format_fixedlength_formats}, + #per-import + job => $job, + file => $file, + #type => $type, + format => $param->{format}, + params => { map { $_ => $param->{$_} } @pass_params }, + #? + default_csv => $opt->{default_csv}, } ); unlink $file; @@ -1356,31 +1504,115 @@ sub process_batch_import { die "$error\n" if $error; } +=item batch_import PARAM_HASHREF + +Class method for batch imports. Available params: + +=over 4 + +=item table + +=item formats + +=item format_types + +=item format_headers + +=item format_sep_chars + +=item format_fixedlength_formats + +=item params + +=item job + +FS::queue object, will be updated with progress + +=item file + +=item type + +csv, xls or fixedlength + +=item format + +=item empty_ok + +=back + +=cut + sub batch_import { my $param = shift; - my $table = $param->{table}; - my $formats = $param->{formats}; - my $params = $param->{params}; - - my $job = $param->{job}; + warn "$me batch_import call with params: \n". Dumper($param) + if $DEBUG; - my $filename = $param->{file}; - my $type = $param->{type} || 'csv'; + my $table = $param->{table}; + my $formats = $param->{formats}; - my $format = $param->{'format'}; + my $job = $param->{job}; + my $file = $param->{file}; + my $format = $param->{'format'}; + my $params = $param->{params} || {}; die "unknown format $format" unless exists $formats->{ $format }; - my @fields = @{ $formats->{ $format } }; + my $type = $param->{'format_types'} + ? $param->{'format_types'}{ $format } + : $param->{type} || 'csv'; + + unless ( $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'; + } + $type = 'csv' + if $param->{'default_csv'} && $type ne 'xls'; + } + + my $header = $param->{'format_headers'} + ? $param->{'format_headers'}{ $param->{'format'} } + : 0; + + my $sep_char = $param->{'format_sep_chars'} + ? $param->{'format_sep_chars'}{ $param->{'format'} } + : ','; + + my $fixedlength_format = + $param->{'format_fixedlength_formats'} + ? $param->{'format_fixedlength_formats'}{ $param->{'format'} } + : ''; + + my @fields = @{ $formats->{ $format } }; + + my $row = 0; my $count; my $parser; my @buffer = (); - if ( $type eq 'csv' ) { + if ( $type eq 'csv' || $type eq 'fixedlength' ) { + + if ( $type eq 'csv' ) { - $parser = new Text::CSV_XS; + my %attr = (); + $attr{sep_char} = $sep_char if $sep_char; + $parser = new Text::CSV_XS \%attr; - @buffer = split(/\r?\n/, slurp($filename) ); + } elsif ( $type eq 'fixedlength' ) { + + eval "use Parse::FixedLength;"; + die $@ if $@; + $parser = new Parse::FixedLength $fixedlength_format; + + } else { + die "Unknown file type $type\n"; + } + + @buffer = split(/\r?\n/, slurp($file) ); + splice(@buffer, 0, ($header || 0) ); $count = scalar(@buffer); } elsif ( $type eq 'xls' ) { @@ -1388,13 +1620,20 @@ sub batch_import { eval "use Spreadsheet::ParseExcel;"; die $@ if $@; - my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($filename); + eval "use DateTime::Format::Excel;"; + #for now, just let the error be thrown if it is used, since only CDR + # formats bill_west and troop use it, not other excel-parsing things + #die $@ if $@; + + my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file); $parser = $excel->{Worksheet}[0]; #first sheet $count = $parser->{MaxRow} || $parser->{MinRow}; $count++; + $row = $header || 0; + } else { die "Unknown file type $type\n"; } @@ -1413,7 +1652,7 @@ sub batch_import { my $dbh = dbh; my $line; - my $row = 0; + my $imported = 0; my( $last, $min_sec ) = ( time, 5 ); #progressbar foo while (1) { @@ -1429,6 +1668,10 @@ sub batch_import { }; @columns = $parser->fields(); + } elsif ( $type eq 'fixedlength' ) { + + @columns = $parser->parse($line); + } elsif ( $type eq 'xls' ) { last if $row > ($parser->{MaxRow} || $parser->{MinRow}) @@ -1444,6 +1687,7 @@ sub batch_import { die "Unknown file type $type\n"; } + my @later = (); my %hash = %$params; foreach my $field ( @fields ) { @@ -1451,9 +1695,11 @@ sub batch_import { my $value = shift @columns; if ( ref($field) eq 'CODE' ) { - &{$field}(\%hash, $value); + #&{$field}(\%hash, $value); + push @later, $field, $value; } else { - $hash{$field} = $value if length($value); + #??? $hash{$field} = $value if length($value); + $hash{$field} = $value if defined($value) && length($value); } } @@ -1462,6 +1708,15 @@ sub batch_import { my $record = $class->new( \%hash ); + my $param = {}; + while ( scalar(@later) ) { + my $sub = shift @later; + my $data = shift @later; + &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf); + last if exists( $param->{skiprow} ); + } + next if exists( $param->{skiprow} ); + my $error = $record->insert; if ( $error ) { @@ -1470,9 +1725,10 @@ sub batch_import { } $row++; + $imported++; if ( $job && time - $min_sec > $last ) { #progress bar - $job->update_statustext( int(100 * $row / $count) ); + $job->update_statustext( int(100 * $imported / $count) ); $last = time; } @@ -1480,7 +1736,7 @@ sub batch_import { $dbh->commit or die $dbh->errstr if $oldAutoCommit;; - return "Empty file!" unless $row; + return "Empty file!" unless $imported || $param->{empty_ok}; ''; #no error @@ -1491,16 +1747,18 @@ sub _h_statement { $time ||= time; + my %nohistory = map { $_=>1 } $self->nohistory_fields; + my @fields = - grep { defined($self->getfield($_)) && $self->getfield($_) ne "" } + grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} } real_fields($self->table); ; - # 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... - if ($conf && $conf->exists('encryption') ) { - @fields = grep $_ ne 'payinfo' && $_ ne 'cvv2', @fields; + # If we're encrypting then don't store the payinfo in the history + if ( $conf && $conf->exists('encryption') ) { + @fields = grep { $_ ne 'payinfo' } @fields; } + my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields; "INSERT INTO h_". $self->table. " ( ". @@ -1707,7 +1965,7 @@ sub ut_money { =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. @@ -1719,7 +1977,7 @@ sub ut_text { #warn "notexist ". \¬exist. "\n"; #warn "AUTOLOAD ". \&AUTOLOAD. "\n"; $self->getfield($field) - =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]+)$/ + =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>]+)$/ or return gettext('illegal_or_empty_text'). " $field: ". $self->getfield($field); $self->setfield($field,$1); @@ -2084,7 +2342,7 @@ sub ut_enum { my( $self, $field, $choices ) = @_; foreach my $choice ( @$choices ) { if ( $self->getfield($field) eq $choice ) { - $self->setfield($choice); + $self->setfield($field, $choice); return ''; } } @@ -2120,15 +2378,18 @@ sub ut_foreign_keyn { : ''; } -=item ut_agentnum_acl +=item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ] Checks this column as an agentnum, taking into account the current users's -ACLs. +ACLs. NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access +right or rights allowing no agentnum. =cut sub ut_agentnum_acl { - my( $self, $field, $null_acl ) = @_; + my( $self, $field ) = (shift, shift); + my $null_acl = scalar(@_) ? shift : []; + $null_acl = [ $null_acl ] unless ref($null_acl); my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum'); return "Illegal agentnum: $error" if $error; @@ -2143,7 +2404,7 @@ sub ut_agentnum_acl { } else { return "Access denied" - unless $curuser->access_right($null_acl); + unless grep $curuser->access_right($_), @$null_acl; }