X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=35ed6f7a894c2013381ef4141d50040da1be0299;hp=b226e177ba9589f8c77fd32ccc607021bc7340ad;hb=a3c8a7c5be8650f5854a1d89f1b76d21d5cfb1a1;hpb=7943c96636596806b9fc99195c23b166728280c8 diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index b226e177b..35ed6f7a8 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -32,7 +32,8 @@ our @encrypt_payby = qw( CARD DCRD CHEK DCHK ); #export dbdef for now... everything else expects to find it here our @EXPORT_OK = qw( dbh fields hfields qsearch qsearchs dbdef jsearch - str2time_sql str2time_sql_closing regexp_sql not_regexp_sql concat_sql + str2time_sql str2time_sql_closing regexp_sql not_regexp_sql + concat_sql group_concat_sql midnight_sql ); @@ -44,6 +45,8 @@ our $nowarn_classload = 0; our $no_update_diff = 0; our $no_history = 0; +our $qsearch_qualify_columns = 1; + our $no_check_foreign = 1; #well, not inefficiently in perl by default anymore my $rsa_module; @@ -124,6 +127,8 @@ FS::Record - Database record objects $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'); @@ -406,7 +411,6 @@ sub qsearch { push @statement, $statement; warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug; - foreach my $field ( grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields @@ -485,6 +489,8 @@ sub qsearch { $sth->finish; + #below was refactored out to _from_hashref, this should use it at some point + my @return; if ( eval 'scalar(@FS::'. $table. '::ISA);' ) { if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) { @@ -741,72 +747,74 @@ sub _from_hashref { return @return; } -## makes this easier to read - 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 { + ## 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-( $column IS NULL OR $column != ? )-; + 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 @@ -870,6 +878,7 @@ sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash); my $table = $_[0]; my(@result) = qsearch(@_); cluck "warning: Multiple records in scalar search ($table)" + #.join(' / ', map "$_=>".$_[1]->{$_}, keys %{ $_[1] } ) if scalar(@result) > 1; #should warn more vehemently if the search was on a primary key? scalar(@result) ? ($result[0]) : (); @@ -1041,7 +1050,10 @@ sub fk_methods { my $method = ''; if ( scalar( @{$fk->columns} ) == 1 ) { - if ( ! @{$fk->references} || $fk->columns->[0] eq $fk->references->[0] ){ + if ( ! defined($fk->references) + || ! @{$fk->references} + || $fk->columns->[0] eq $fk->references->[0] + ) { $method = $fk->table; } else { #some sort of hint in the table.pm or schema for methods not named @@ -1072,7 +1084,10 @@ sub fk_methods { my $method = ''; if ( scalar( @{$fk->columns} ) == 1 ) { - if ( ! @{$fk->references} || $fk->columns->[0] eq $fk->references->[0] ){ + if ( ! defined($fk->references) + || ! @{$fk->references} + || $fk->columns->[0] eq $fk->references->[0] + ) { $method = $f_table; } else { #some sort of hint in the table.pm or schema for methods not named @@ -1127,13 +1142,27 @@ sub hashref { $self->{'Hash'}; } -#fallback +#fallbacks/generics + sub API_getinfo { my $self = shift; +{ ( map { $_=>$self->$_ } $self->fields ), }; } +sub API_insert { + my( $class, %opt ) = @_; + my $table = $class->table; + my $self = $class->new( { map { $_ => $opt{$_} } fields($table) } ); + my $error = $self->insert; + return +{ 'error' => $error } if $error; + my $pkey = $self->pkey; + return +{ 'error' => '', + 'primary_key' => $pkey, + $pkey => $self->$pkey, + }; +} + =item modified Returns true if any of this object's values have been modified with set (or via @@ -1689,7 +1718,7 @@ Table name (required). =item params -Listref of field names for static fields. They will be given values from the +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 @@ -1738,24 +1767,21 @@ 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". +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 -use Storable qw(thaw); use Data::Dumper; -use MIME::Base64; sub process_batch_import { - my($job, $opt) = ( shift, shift ); + my($job, $opt, $param) = @_; my $table = $opt->{table}; my @pass_params = $opt->{params} ? @{ $opt->{params} } : (); my %formats = %{ $opt->{formats} }; - my $param = thaw(decode_base64(shift)); warn Dumper($param) if $DEBUG; my $files = $param->{'uploaded_files'} @@ -1786,6 +1812,7 @@ sub process_batch_import { #? default_csv => $opt->{default_csv}, postinsert_callback => $opt->{postinsert_callback}, + insert_args_callback => $opt->{insert_args_callback}, ); if ( $opt->{'batch_namecol'} ) { @@ -1872,6 +1899,9 @@ sub batch_import { 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'} ) { @@ -2181,7 +2211,12 @@ sub batch_import { next if exists $param->{skiprow} && $param->{skiprow}; } - my $error = $record->insert; + 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; @@ -2420,6 +2455,35 @@ sub ut_numbern { ''; } +=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 @@ -2599,8 +2663,8 @@ sub ut_alpha_lower { 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 @@ -3045,7 +3109,7 @@ on the column first. sub ut_foreign_key { my( $self, $field, $table, $foreign ) = @_; - return '' if $no_check_foreign; + return $self->ut_number($field) if $no_check_foreign; qsearchs($table, { $foreign => $self->getfield($field) }) or return "Can't find ". $self->table. ".$field ". $self->getfield($field). " in $table.$foreign"; @@ -3085,12 +3149,12 @@ sub ut_agentnum_acl { if ( $self->$field() ) { - return "Access denied" + return 'Access denied to agent '. $self->$field() unless $curuser->agentnum($self->$field()); } else { - return "Access denied" + return 'Access denied to global' unless grep $curuser->access_right($_), @$null_acl; } @@ -3113,7 +3177,7 @@ sub fields { $table = $something->table; } else { $table = $something; - $something = "FS::$table"; + #$something = "FS::$table"; } return (real_fields($table)); } @@ -3272,7 +3336,7 @@ sub scalar_sql { defined($scalar) ? $scalar : ''; } -=item count [ WHERE ] +=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 @@ -3285,7 +3349,23 @@ sub count { 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); + $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 @@ -3521,6 +3601,24 @@ sub concat_sql { } +=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