X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=c3d397389a75d76470a2494312c9a1eadcf69d23;hp=05deaef1e2a8ee54339b51067f2c79401e17f407;hb=a36e0f8a0f69349dafaa16d1d2d57dfb6e5dbc85;hpb=506e9a0e82676ce8141326fbb98972044476168b diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index 05deaef1e..c3d397389 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -2,8 +2,9 @@ package FS::Record; use base qw( Exporter ); use strict; +use charnames ':full'; use vars qw( $AUTOLOAD - %virtual_fields_cache + %virtual_fields_cache %fk_method_cache $fk_table_cache $money_char $lat_lower $lon_upper ); use Carp qw(carp cluck croak confess); @@ -32,8 +33,9 @@ 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 - midnight_sql + str2time_sql str2time_sql_closing regexp_sql not_regexp_sql + concat_sql group_concat_sql + midnight_sql fk_methods_init ); our $DEBUG = 0; @@ -44,6 +46,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; @@ -53,12 +57,18 @@ my $rsa_decrypt; our $conf = ''; our $conf_encryption = ''; +our $conf_encryptionmodule = ''; +our $conf_encryptionpublickey = ''; +our $conf_encryptionprivatekey = ''; FS::UID->install_callback( sub { eval "use FS::Conf;"; die $@ if $@; $conf = FS::Conf->new; - $conf_encryption = $conf->exists('encryption'); + $conf_encryption = $conf->exists('encryption'); + $conf_encryptionmodule = $conf->config('encryptionmodule'); + $conf_encryptionpublickey = join("\n",$conf->config('encryptionpublickey')); + $conf_encryptionprivatekey = join("\n",$conf->config('encryptionprivatekey')); $money_char = $conf->config('money_char') || '$'; my $nw_coords = $conf->exists('geocode-require_nw_coordinates'); $lat_lower = $nw_coords ? 1 : -90; @@ -73,6 +83,8 @@ FS::UID->install_callback( sub { eval "sub PG_BYTEA { die 'guru meditation #9: calling PG_BYTEA when not running Pg?'; }"; } + #fk_methods_init(); + } ); =head1 NAME @@ -120,6 +132,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'); @@ -186,6 +200,7 @@ sub new { $self->{'modified'} = 0; + $self->_simplecache($self->{'Hash'}) if $self->can('_simplecache'); $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_; $self; @@ -363,6 +378,9 @@ sub qsearch { my @bind_type = (); my $dbh = dbh; foreach my $stable ( @stable ) { + + carp '->qsearch on cust_main called' if $stable eq 'cust_main' && $DEBUG; + #stop altering the caller's hashref my $record = { %{ shift(@record) || {} } };#and be liberal in receipt my $select = shift @select; @@ -387,10 +405,17 @@ sub qsearch { my @real_fields = grep exists($record->{$_}), real_fields($table); my $statement .= "SELECT $select FROM $stable"; - $statement .= " $addl_from" if $addl_from; + my $alias_main; + if ( $addl_from ) { + $statement .= " $addl_from"; + # detect aliasing of the main table + if ( $addl_from =~ /^\s*AS\s+(\w+)/i ) { + $alias_main = $1; + } + } if ( @real_fields ) { $statement .= ' WHERE '. join(' AND ', - get_real_fields($table, $record, \@real_fields)); + get_real_fields($table, $record, \@real_fields, $alias_main)); } $statement .= " $extra_sql" if defined($extra_sql); @@ -399,7 +424,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 @@ -478,6 +502,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 ) { @@ -501,6 +527,7 @@ sub qsearch { # 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 && eval '@FS::'. $table . '::encrypted_fields' ) { foreach my $record (@return) { @@ -734,72 +761,76 @@ sub _from_hashref { return @return; } -## makes this easier to read - sub get_real_fields { my $table = shift; my $record = shift; my $real_fields = shift; + my $alias_main = shift; # defaults to undef + $alias_main ||= $table; - ## 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 ? "$alias_main.$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 @@ -863,6 +894,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]) : (); @@ -956,12 +988,17 @@ sub exists { exists($self->{Hash}->{$field}); } -=item AUTLOADED METHODS +=item AUTOLOADED METHODS $record->column is a synonym for $record->get('column'); $record->column('value') is a synonym for $record->set('column','value'); +$record->foreign_table_name calls qsearchs and returns a single +FS::foreign_table record (for tables referenced by a column of this table) or +qsearch and returns an array of FS::foreign_table records (for tables +referenced by a column in the foreign table). + =cut # readable/safe @@ -969,18 +1006,44 @@ sub AUTOLOAD { my($self,$value)=@_; my($field)=$AUTOLOAD; $field =~ s/.*://; + + confess "errant AUTOLOAD $field for $self (arg $value)" + unless blessed($self) && $self->can('setfield'); + + if ( my $fk_info = get_fk_method($self->table, $field) ) { + + my $method = $fk_info->{method} || 'qsearchs'; + my $table = $fk_info->{table} || $field; + my $column = $fk_info->{column}; + my $foreign_column = $fk_info->{references} || $column; + + eval "use FS::$table"; + die $@ if $@; + + carp '->cust_main called' if $table eq 'cust_main' && $DEBUG; + + my $pkey_value = $self->$column(); + my %search = ( $foreign_column => $pkey_value ); + + # FS::Record->$method() ? they're actually just subs :/ + if ( $method eq 'qsearchs' ) { + return $pkey_value ? qsearchs( $table, \%search ) : ''; + } elsif ( $method eq 'qsearch' ) { + return $pkey_value ? qsearch( $table, \%search ) : (); + } else { + die "unknown method $method"; + } + + } + if ( defined($value) ) { - confess "errant AUTOLOAD $field for $self (arg $value)" - unless blessed($self) && $self->can('setfield'); $self->setfield($field,$value); } else { - confess "errant AUTOLOAD $field for $self (no args)" - unless blessed($self) && $self->can('getfield'); $self->getfield($field); } } -# efficient +# efficient (also, old, doesn't support FK stuff) #sub AUTOLOAD { # my $field = $AUTOLOAD; # $field =~ s/.*://; @@ -991,6 +1054,110 @@ sub AUTOLOAD { # } #} +# get_fk_method(TABLE, FIELD) +# Internal subroutine for fetching the foreign key descriptor for TABLE.FIELD +# if there is one. If not, returns undef. +# This will initialize fk_method_cache if it hasn't happened yet. It is the +# _only_ allowed way to access the contents of %fk_method_cache. + +# if we wanted to be even more efficient we'd create the fk methods in the +# symbol table instead of relying on AUTOLOAD every time + +sub get_fk_method { + my ($table, $field) = @_; + + # maybe should only load one table at a time? + fk_methods_init() unless exists($fk_method_cache{$table}); + + if ( exists($fk_method_cache{$table}) and + exists($fk_method_cache{$table}{$field}) ) { + return $fk_method_cache{$table}{$field}; + } else { + return undef; + } + +} + +sub fk_methods_init { + warn "[fk_methods_init]\n" if $DEBUG; + foreach my $table ( dbdef->tables ) { + $fk_method_cache{$table} = fk_methods($table); + } +} + +sub fk_methods { + my $table = shift; + + my %hash = (); + + # foreign keys we reference in other tables + foreach my $fk (dbdef->table($table)->foreign_keys) { + + my $method = ''; + if ( scalar( @{$fk->columns} ) == 1 ) { + 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 + # after their foreign table (well, not a whole lot different than + # just providing a small subroutine...) + } + + if ( $method ) { + $hash{$method} = { #fk_info + 'method' => 'qsearchs', + 'column' => $fk->columns->[0], + #'references' => $fk->references->[0], + }; + } + + } + + } + + # foreign keys referenced in other tables to us + # (alas. why we're cached. still, might this loop better be done once at + # schema load time insetad of every time we AUTOLOAD a method on a new + # class?) + if (! defined $fk_table_cache) { + foreach my $f_table ( dbdef->tables ) { + foreach my $fk (dbdef->table($f_table)->foreign_keys) { + push @{$fk_table_cache->{$fk->table}},[$f_table,$fk]; + } + } + } + foreach my $fks (@{$fk_table_cache->{$table}}) { + my ($f_table,$fk) = @$fks; + my $method = ''; + if ( scalar( @{$fk->columns} ) == 1 ) { + 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 + # after their foreign table (well, not a whole lot different than + # just providing a small subroutine...) + } + + if ( $method ) { + $hash{$method} = { #fk_info + 'method' => 'qsearch', + 'column' => $fk->columns->[0], #references||column + #'references' => $fk->column->[0], + }; + } + + } + } + + \%hash; +} + =item hash Returns a list of the column/value pairs, usually for assigning to a new hash. @@ -1021,6 +1188,27 @@ sub hashref { $self->{'Hash'}; } +#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 @@ -1142,9 +1330,8 @@ sub insert { my $table = $self->table; # Encrypt before the database - if ( defined(eval '@FS::'. $table . '::encrypted_fields') - && scalar( eval '@FS::'. $table . '::encrypted_fields') - && $conf->exists('encryption') + if ( scalar( eval '@FS::'. $table . '::encrypted_fields') + && $conf_encryption ) { foreach my $field (eval '@FS::'. $table . '::encrypted_fields') { next if $field eq 'payinfo' @@ -1251,7 +1438,7 @@ sub insert { } my $h_sth; - if ( defined dbdef->table('h_'. $table) ) { + if ( defined( dbdef->table('h_'. $table) ) && ! $no_history ) { my $h_statement = $self->_h_statement('insert'); warn "[debug]$me $h_statement\n" if $DEBUG > 2; $h_sth = dbh->prepare($h_statement) or do { @@ -1385,9 +1572,8 @@ sub replace { # Encrypt for replace my $saved = {}; - if ( $conf->exists('encryption') - && defined(eval '@FS::'. $new->table . '::encrypted_fields') - && scalar( eval '@FS::'. $new->table . '::encrypted_fields') + if ( scalar( eval '@FS::'. $new->table . '::encrypted_fields') + && $conf_encryption ) { foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') { next if $field eq 'payinfo' @@ -1516,7 +1702,7 @@ sub rep { =item check Checks custom fields. Subclasses should still provide a check method to validate -non-custom fields, foreign keys, etc., and call this method via $self->SUPER::check. +non-custom fields, etc., and call this method via $self->SUPER::check. =cut @@ -1576,7 +1762,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 @@ -1625,24 +1811,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'} @@ -1664,6 +1847,7 @@ sub process_batch_import { format_xml_formats => $opt->{format_xml_formats}, format_asn_formats => $opt->{format_asn_formats}, format_row_callbacks => $opt->{format_row_callbacks}, + format_hash_callbacks => $opt->{format_hash_callbacks}, #per-import job => $job, file => $file, @@ -1672,7 +1856,9 @@ sub process_batch_import { params => { map { $_ => $param->{$_} } @pass_params }, #? default_csv => $opt->{default_csv}, + preinsert_callback => $opt->{preinsert_callback}, postinsert_callback => $opt->{postinsert_callback}, + insert_args_callback => $opt->{insert_args_callback}, ); if ( $opt->{'batch_namecol'} ) { @@ -1709,6 +1895,8 @@ Class method for batch imports. Available params: =item format_row_callbacks +=item format_hash_callbacks - After parsing, before object creation + =item fields - Alternate way to specify import, specifying import fields directly as a listref =item preinsert_callback @@ -1746,9 +1934,12 @@ sub batch_import { my $file = $param->{file}; my $params = $param->{params} || {}; + my $custnum_prefix = $conf->config('cust_main-custnum-display_prefix'); + my $custnum_length = $conf->config('cust_main-custnum-display_length') || 8; + my( $type, $header, $sep_char, $fixedlength_format, $xml_format, $asn_format, - $row_callback, @fields ); + $parser_opt, $row_callback, $hash_callback, @fields ); my $postinsert_callback = ''; $postinsert_callback = $param->{'postinsert_callback'} @@ -1756,6 +1947,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'} ) { @@ -1781,6 +1975,11 @@ sub batch_import { ? $param->{'format_fixedlength_formats'}{ $param->{'format'} } : ''; + $parser_opt = + $param->{'format_parser_opts'} + ? $param->{'format_parser_opts'}{ $param->{'format'} } + : {}; + $xml_format = $param->{'format_xml_formats'} ? $param->{'format_xml_formats'}{ $param->{'format'} } @@ -1796,6 +1995,11 @@ sub batch_import { ? $param->{'format_row_callbacks'}{ $param->{'format'} } : ''; + $hash_callback = + $param->{'format_hash_callbacks'} + ? $param->{'format_hash_callbacks'}{ $param->{'format'} } + : ''; + @fields = @{ $formats->{ $format } }; } elsif ( $param->{'fields'} ) { @@ -1805,6 +2009,7 @@ sub batch_import { $sep_char = ','; $fixedlength_format = ''; $row_callback = ''; + $hash_callback = ''; @fields = @{ $param->{'fields'} }; } else { @@ -1835,18 +2040,17 @@ sub batch_import { if ( $type eq 'csv' ) { - my %attr = ( 'binary' => 1, ); - $attr{sep_char} = $sep_char if $sep_char; - $parser = new Text::CSV_XS \%attr; + $parser_opt->{'binary'} = 1; + $parser_opt->{'sep_char'} = $sep_char if $sep_char; + $parser = Text::CSV_XS->new($parser_opt); } elsif ( $type eq 'fixedlength' ) { eval "use Parse::FixedLength;"; die $@ if $@; - $parser = Parse::FixedLength->new($fixedlength_format); + $parser = Parse::FixedLength->new($fixedlength_format, $parser_opt); - } - else { + } else { die "Unknown file type $type\n"; } @@ -1949,6 +2153,7 @@ sub batch_import { #my $job = $param->{job}; my $line; my $imported = 0; + my $unique_skip = 0; #lines skipped because they're already in the system my( $last, $min_sec ) = ( time, 5 ); #progressbar foo while (1) { @@ -2026,6 +2231,13 @@ sub batch_import { } + if ( $custnum_prefix && $hash{custnum} =~ /^$custnum_prefix(0*([1-9]\d*))$/ + && length($1) == $custnum_length ) { + $hash{custnum} = $2; + } + + %hash = &{$hash_callback}(%hash) if $hash_callback; + #my $table = $param->{table}; my $class = "FS::$table"; @@ -2044,6 +2256,7 @@ sub batch_import { } last if exists( $param->{skiprow} ); } + $unique_skip++ if $param->{unique_skip}; #line is already in the system next if exists( $param->{skiprow} ); if ( $preinsert_callback ) { @@ -2056,7 +2269,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; @@ -2084,7 +2302,8 @@ sub batch_import { unless ( $imported || $param->{empty_ok} ) { $dbh->rollback if $oldAutoCommit; - return "Empty file!"; + # freeside-cdr-conexiant-import is sensitive to the text of this message + return $unique_skip ? "All records in file were previously imported" : "Empty file!"; } $dbh->commit or die $dbh->errstr if $oldAutoCommit; @@ -2106,7 +2325,7 @@ sub _h_statement { ; # If we're encrypting then don't store the payinfo in the history - if ( $conf && $conf->exists('encryption') && $self->table ne 'banned_pay' ) { + if ( $conf_encryption && $self->table ne 'banned_pay' ) { @fields = grep { $_ ne 'payinfo' } @fields; } @@ -2295,6 +2514,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 @@ -2384,8 +2632,10 @@ sub ut_text { #warn "msgcat ". \&msgcat. "\n"; #warn "notexist ". \¬exist. "\n"; #warn "AUTOLOAD ". \&AUTOLOAD. "\n"; + # \p{Word} = alphanumerics, marks (diacritics), and connectors + # see perldoc perluniprops $self->getfield($field) - =~ /^([\wô \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/ + =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/ or return gettext('illegal_or_empty_text'). " $field: ". $self->getfield($field); $self->setfield($field,$1); @@ -2472,8 +2722,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 @@ -2664,6 +2914,10 @@ sub ut_coord { my $coord = $self->getfield($field); my $neg = $coord =~ s/^(-)//; + # ignore degree symbol at the end, + # but not otherwise supporting degree/minutes/seconds symbols + $coord =~ s/\N{DEGREE SIGN}\s*$//; + my ($d, $m, $s) = (0, 0, 0); if ( @@ -2758,8 +3012,7 @@ May not be null. sub ut_name { my( $self, $field ) = @_; -# warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n"; - $self->getfield($field) =~ /^([\w \,\.\-\']+)$/ + $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/ or return gettext('illegal_name'). " $field: ". $self->getfield($field); my $name = $1; $name =~ s/^\s+//; @@ -2918,7 +3171,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"; @@ -2958,12 +3211,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; } @@ -2972,6 +3225,22 @@ sub ut_agentnum_acl { } +=item trim_whitespace FIELD[, FIELD ... ] + +Strip leading and trailing spaces from the value in the named FIELD(s). + +=cut + +sub trim_whitespace { + my $self = shift; + foreach my $field (@_) { + my $value = $self->get($field); + $value =~ s/^\s+//; + $value =~ s/\s+$//; + $self->set($field, $value); + } +} + =item fields [ TABLE ] This is a wrapper for real_fields. Code that called @@ -2986,7 +3255,7 @@ sub fields { $table = $something->table; } else { $table = $something; - $something = "FS::$table"; + #$something = "FS::$table"; } return (real_fields($table)); } @@ -3004,9 +3273,9 @@ You should generally not have to worry about calling this, as the system handles sub encrypt { my ($self, $value) = @_; - my $encrypted; + my $encrypted = $value; - if ($conf->exists('encryption')) { + if ($conf_encryption) { if ($self->is_encrypted($value)) { # Return the original value if it isn't plaintext. $encrypted = $value; @@ -3049,7 +3318,7 @@ 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. - if ($conf->exists('encryption') && $self->is_encrypted($value)) { + if ($conf_encryption && $self->is_encrypted($value)) { $self->loadRSA; if (ref($rsa_decrypt) =~ /::RSA/) { my $encrypted = unpack ("u*", $value); @@ -3065,8 +3334,8 @@ sub loadRSA { #Initialize the Module $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default - if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') { - $rsa_module = $conf->config('encryptionmodule'); + if ($conf_encryptionmodule && $conf_encryptionmodule ne '') { + $rsa_module = $conf_encryptionmodule; } if (!$rsa_loaded) { @@ -3074,15 +3343,13 @@ sub loadRSA { $rsa_loaded++; } # Initialize Encryption - if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') { - my $public_key = join("\n",$conf->config('encryptionpublickey')); - $rsa_encrypt = $rsa_module->new_public_key($public_key); + if ($conf_encryptionpublickey && $conf_encryptionpublickey ne '') { + $rsa_encrypt = $rsa_module->new_public_key($conf_encryptionpublickey); } # Intitalize Decryption - if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') { - my $private_key = join("\n",$conf->config('encryptionprivatekey')); - $rsa_decrypt = $rsa_module->new_private_key($private_key); + if ($conf_encryptionprivatekey && $conf_encryptionprivatekey ne '') { + $rsa_decrypt = $rsa_module->new_private_key($conf_encryptionprivatekey); } } @@ -3145,7 +3412,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 @@ -3158,7 +3425,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 @@ -3219,6 +3502,8 @@ sub _quote { my $column_type = $column_obj->type; my $nullable = $column_obj->null; + utf8::upgrade($value); + warn " $table.$column: $value ($column_type". ( $nullable ? ' NULL' : ' NOT NULL' ). ")\n" if $DEBUG > 2; @@ -3392,6 +3677,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