X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=2540dd399f40eca00168f863cb83a125cd502209;hp=d843658044df8b9db26b76453f6234408c54bd3b;hb=ec5603ae351d4ed8e4873dcd20bf71f8a4d549bb;hpb=673b9a458d9138523026963df6fa3b4683e09bae diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index d84365804..2540dd399 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -2,18 +2,23 @@ package FS::Record; use strict; use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG - $me %virtual_fields_cache $nowarn_identical ); + $conf $me + %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 DBI qw(:sql_types); -use DBIx::DBSchema 0.25; +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; @@ -22,24 +27,29 @@ 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 $conf; my $rsa_module; my $rsa_loaded; my $rsa_encrypt; my $rsa_decrypt; FS::UID->install_callback( sub { - $conf = new FS::Conf; - $File::CounterFile::DEFAULT_DIR = "/usr/local/etc/freeside/counters.". datasrc; + eval "use FS::Conf;"; + die $@ if $@; + $conf = FS::Conf->new; + $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc; } ); + =head1 NAME FS::Record - Database record objects @@ -82,8 +92,11 @@ FS::Record - Database record objects $value = $record->unique('column'); $error = $record->ut_float('column'); + $error = $record->ut_floatn('column'); $error = $record->ut_number('column'); $error = $record->ut_numbern('column'); + $error = $record->ut_snumber('column'); + $error = $record->ut_snumbern('column'); $error = $record->ut_money('column'); $error = $record->ut_text('column'); $error = $record->ut_textn('column'); @@ -205,8 +218,10 @@ The preferred usage is to pass a hash reference of named parameters: #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, } ); @@ -226,16 +241,21 @@ fine in the common case where there are only two parameters: =cut +my %TYPE = (); #for debugging + sub qsearch { - my($stable, $record, $select, $extra_sql, $cache, $addl_from ); + 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"; $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'} || ''; } else { ($stable, $record, $select, $extra_sql, $cache, $addl_from ) = @_; $select ||= '*'; @@ -250,7 +270,7 @@ sub qsearch { my $table = $cache ? $cache->table : $stable; my $dbdef_table = dbdef->table($table) or die "No schema for table $table found - ". - "do you need to create it or run dbdef-create?"; + "do you need to run freeside-upgrade?"; my $pkey = $dbdef_table->primary_key; my @real_fields = grep exists($record->{$_}), real_fields($table); @@ -266,96 +286,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|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|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"; @@ -364,13 +303,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|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 + #} elsif ( ( $type =~ /(numeric)/i && $value =~ /^[+-]?\d+(\.\d+)?$/) + # || ( $type =~ /(real|float4)/i + # && $value =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/ + # ) + # ) { + # $TYPE = SQL_FLOAT; + } + + 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->{$_}, @@ -389,7 +348,7 @@ sub qsearch { my %result; tie %result, "Tie::IxHash"; my @stuff = @{ $sth->fetchall_arrayref( {} ) }; - if($pkey) { + if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) { %result = map { $_->{$pkey}, $_ } @stuff; } else { @result{@stuff} = @stuff; @@ -433,14 +392,19 @@ sub qsearch { } values(%result); } } else { - warn "untested code (class FS::$table uses custom new method)"; + #okay, its been tested + # warn "untested code (class FS::$table uses custom new method)"; @return = map { eval 'FS::'. $table. '->new( { %{$_} } )'; } values(%result); } # Check for encrypted fields and decrypt them. - if ($conf->exists('encryption') && eval 'defined(@FS::'. $table . '::encrypted_fields)') { + ## 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)') { foreach my $record (@return) { foreach my $field (eval '@FS::'. $table . '::encrypted_fields') { # Set it directly... This may cause a problem in the future... @@ -457,6 +421,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 @@ -553,6 +621,17 @@ sub dbdef_table { dbdef->table($table); } +=item primary_key + +Returns the primary key for the table. + +=cut + +sub primary_key { + my $self = shift; + my $pkey = $self->dbdef_table->primary_key; +} + =item get, getfield COLUMN Returns the value of the column/field/key COLUMN. @@ -604,11 +683,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); } } @@ -667,6 +746,24 @@ sub modified { $self->{'modified'}; } +=item select_for_update + +Selects this record with the SQL "FOR UPDATE" command. This can be useful as +a mutex. + +=cut + +sub select_for_update { + my $self = shift; + my $primary_key = $self->primary_key; + qsearchs( { + 'select' => '*', + 'table' => $self->table, + 'hashref' => { $primary_key => $self->$primary_key() }, + 'extra_sql' => 'FOR UPDATE', + } ); +} + =item insert Inserts this record to the database. If there is an error, returns the error, @@ -678,12 +775,14 @@ sub insert { my $self = shift; my $saved = {}; + warn "$self -> insert" if $DEBUG; + my $error = $self->check; return $error if $error; #single-field unique keys are given a value if false #(like MySQL's AUTO_INCREMENT or Pg SERIAL) - foreach ( $self->dbdef_table->unique->singles ) { + foreach ( $self->dbdef_table->unique_singles) { $self->unique($_) unless $self->getfield($_); } @@ -694,7 +793,7 @@ sub insert { my $col = $self->dbdef_table->column($primary_key); $db_seq = - uc($col->type) eq 'SERIAL' + uc($col->type) =~ /^(BIG)?SERIAL\d?/ || ( driver_name eq 'Pg' && defined($col->default) && $col->default =~ /^nextval\(/i @@ -707,31 +806,38 @@ sub insert { } my $table = $self->table; - # Encrypt before the database - 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->enrypt($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 "", + grep { defined($self->getfield($_)) && $self->getfield($_) ne "" } real_fields($table) ; my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields; #eslaf - my $statement = "INSERT INTO $table ( ". - join( ', ', @real_fields ). - ") VALUES (". - join( ', ', @values ). - ")" - ; + my $statement = "INSERT INTO $table "; + if ( @real_fields ) { + $statement .= + "( ". + join( ', ', @real_fields ). + ") VALUES (". + join( ', ', @values ). + ")" + ; + } else { + $statement .= 'DEFAULT VALUES'; + } warn "[debug]$me $statement\n" if $DEBUG > 1; my $sth = dbh->prepare($statement) or return dbh->errstr; @@ -744,18 +850,31 @@ sub insert { $sth->execute or return $sth->errstr; - my $insertid = ''; - if ( $db_seq ) { # get inserted id from the database, if applicable + # get inserted id from the database, if applicable & needed + if ( $db_seq && ! $self->getfield($primary_key) ) { warn "[debug]$me retreiving sequence from database\n" if $DEBUG; + + my $insertid = ''; + if ( driver_name eq 'Pg' ) { - my $oid = $sth->{'pg_oid_status'}; - my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?"; + #my $oid = $sth->{'pg_oid_status'}; + #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?"; + + my $default = $self->dbdef_table->column($primary_key)->default; + unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) { + dbh->rollback if $FS::UID::AutoCommit; + return "can't parse $table.$primary_key default value". + " for sequence name: $default"; + } + my $sequence = $1; + + my $i_sql = "SELECT currval('$sequence')"; my $i_sth = dbh->prepare($i_sql) or do { dbh->rollback if $FS::UID::AutoCommit; return dbh->errstr; }; - $i_sth->execute($oid) or do { + $i_sth->execute() or do { #$i_sth->execute($oid) dbh->rollback if $FS::UID::AutoCommit; return $i_sth->errstr; }; @@ -781,11 +900,15 @@ sub insert { } } else { + dbh->rollback if $FS::UID::AutoCommit; return "don't know how to retreive inserted ids from ". driver_name. ", try using counterfiles (maybe run dbdef-create?)"; + } + $self->setfield($primary_key, $insertid); + } my @virtual_fields = @@ -940,24 +1063,17 @@ returns the error, otherwise returns false. =cut sub replace { - my $new = shift; - my $old = shift; - - if (!defined($old)) { - warn "[debug]$me replace called with no arguments; autoloading old record\n" - if $DEBUG; - my $primary_key = $new->dbdef_table->primary_key; - if ( $primary_key ) { - $old = qsearchs($new->table, { $primary_key => $new->$primary_key() } ) - or croak "can't find ". $new->table. ".$primary_key ". - $new->$primary_key(); - } else { - croak $new->table. " has no primary key; pass old record as argument"; - } - } + my ($new, $old) = (shift, shift); + + $old = $new->replace_old unless defined($old); warn "[debug]$me $new ->replace $old\n" if $DEBUG; + if ( $new->can('replace_check') ) { + my $error = $new->replace_check($old); + return $error if $error; + } + return "Records not in same table!" unless $new->table eq $old->table; my $primary_key = $old->dbdef_table->primary_key; @@ -972,7 +1088,7 @@ sub replace { # Encrypt for replace my $saved = {}; - if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . 'encrypted_fields')) { + if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . '::encrypted_fields')) { foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') { $saved->{$field} = $new->getfield($field); $new->setfield($field, $new->encrypt($new->getfield($field))); @@ -983,7 +1099,7 @@ sub replace { my %diff = map { ($new->getfield($_) ne $old->getfield($_)) ? ($_, $new->getfield($_)) : () } $old->fields; - unless ( keys(%diff) ) { + unless (keys(%diff) || $no_update_diff ) { carp "[warning]$me $new -> replace $old: records identical" unless $nowarn_identical; return ''; @@ -1002,7 +1118,7 @@ sub replace { #false laziness w/qsearch if ( driver_name eq 'Pg' ) { my $type = $old->dbdef_table->column($_)->type; - if ( $type =~ /(int|serial)/i ) { + if ( $type =~ /(int|(big)?serial)/i ) { qq-( $_ IS NULL )-; } else { qq-( $_ IS NULL OR $_ = '' )-; @@ -1118,6 +1234,22 @@ sub replace { } +sub replace_old { + my( $self ) = shift; + warn "[$me] replace called with no arguments; autoloading old record\n" + if $DEBUG; + + my $primary_key = $self->dbdef_table->primary_key; + if ( $primary_key ) { + $self->by_key( $self->$primary_key() ) #this is what's returned + or croak "can't find ". $self->table. ".$primary_key ". + $self->$primary_key(); + } else { + croak $self->table. " has no primary key; pass old record as argument"; + } + +} + =item rep Depriciated (use replace instead). @@ -1168,9 +1300,15 @@ sub _h_statement { $time ||= time; my @fields = - grep defined($self->getfield($_)) && $self->getfield($_) ne "", + grep { defined($self->getfield($_)) && $self->getfield($_) ne "" } 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; + } my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields; "INSERT INTO h_". $self->table. " ( ". @@ -1232,55 +1370,126 @@ 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); ''; } +=item ut_floatn COLUMN -=item ut_snumber COLUMN - -Check/untaint signed numeric data (whole numbers). May not be null. If there -is an error, returns the error, otherwise returns false. +Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be +null. If there is an error, returns the error, otherwise returns false. =cut -sub ut_snumber { - my($self, $field) = @_; - $self->getfield($field) =~ /^(-?)\s*(\d+)$/ - or return "Illegal or empty (numeric) $field: ". $self->getfield($field); - $self->setfield($field, "$1$2"); - ''; +#false laziness w/ut_ipn +sub ut_floatn { + my( $self, $field ) = @_; + if ( $self->getfield($field) =~ /^()$/ ) { + $self->setfield($field,''); + ''; + } else { + $self->ut_float($field); + } } -=item ut_number COLUMN +=item ut_sfloat COLUMN -Check/untaint simple numeric data (whole numbers). May not be null. If there -is an error, returns the error, otherwise returns false. +Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10. +May not be null. If there is an error, returns the error, otherwise returns +false. =cut -sub ut_number { - my($self,$field)=@_; - $self->getfield($field) =~ /^(\d+)$/ - or return "Illegal or empty (numeric) $field: ". $self->getfield($field); +sub ut_sfloat { + my($self,$field)=@_ ; + ($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); ''; } +=item ut_sfloatn COLUMN -=item ut_numbern COLUMN - -Check/untaint simple numeric data (whole numbers). May be null. If there is -an error, returns the error, otherwise returns false. +Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be +null. If there is an error, returns the error, otherwise returns false. + +=cut + +sub ut_sfloatn { + my( $self, $field ) = @_; + if ( $self->getfield($field) =~ /^()$/ ) { + $self->setfield($field,''); + ''; + } else { + $self->ut_sfloat($field); + } +} + +=item ut_snumber COLUMN + +Check/untaint signed numeric data (whole numbers). If there is an error, +returns the error, otherwise returns false. + +=cut + +sub ut_snumber { + my($self, $field) = @_; + $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/ + or return "Illegal or empty (numeric) $field: ". $self->getfield($field); + $self->setfield($field, "$1$2"); + ''; +} + +=item ut_snumbern COLUMN + +Check/untaint signed numeric data (whole numbers). If there is an error, +returns the error, otherwise returns false. + +=cut + +sub ut_snumbern { + my($self, $field) = @_; + $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/ + or return "Illegal (numeric) $field: ". $self->getfield($field); + if ($1) { + return "Illegal (numeric) $field: ". $self->getfield($field) + unless $2; + } + $self->setfield($field, "$1$2"); + ''; +} + +=item ut_number COLUMN + +Check/untaint simple numeric data (whole numbers). May not be null. If there +is an error, returns the error, otherwise returns false. + +=cut + +sub ut_number { + my($self,$field)=@_; + $self->getfield($field) =~ /^\s*(\d+)\s*$/ + or return "Illegal or empty (numeric) $field: ". $self->getfield($field); + $self->setfield($field,$1); + ''; +} + +=item ut_numbern COLUMN + +Check/untaint simple numeric data (whole numbers). May be null. If there is +an error, returns the error, otherwise returns false. =cut 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); ''; @@ -1296,7 +1505,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); @@ -1306,7 +1515,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. @@ -1317,9 +1526,10 @@ sub ut_text { #warn "msgcat ". \&msgcat. "\n"; #warn "notexist ". \¬exist. "\n"; #warn "AUTOLOAD ". \&AUTOLOAD. "\n"; - $self->getfield($field) =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=]+)$/ - or return gettext('illegal_or_empty_text'). " $field: ". - $self->getfield($field); + $self->getfield($field) + =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]+)$/ + or return gettext('illegal_or_empty_text'). " $field: ". + $self->getfield($field); $self->setfield($field,$1); ''; } @@ -1334,8 +1544,9 @@ May be null. If there is an error, returns the error, otherwise returns false. sub ut_textn { my($self,$field)=@_; - $self->getfield($field) =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=]*)$/ - or return gettext('illegal_text'). " $field: ". $self->getfield($field); + $self->getfield($field) + =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]*)$/ + or return gettext('illegal_text'). " $field: ". $self->getfield($field); $self->setfield($field,$1); ''; } @@ -1371,6 +1582,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 @@ -1389,6 +1614,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"; @@ -1401,6 +1628,33 @@ sub ut_phonen { ''; } +=item ut_hex COLUMN + +Check/untaint hexadecimal values. + +=cut + +sub ut_hex { + my($self, $field) = @_; + $self->getfield($field) =~ /^([\da-fA-F]+)$/ + or return "Illegal (hex) $field: ". $self->getfield($field); + $self->setfield($field, uc($1)); + ''; +} + +=item ut_hexn COLUMN + +Check/untaint hexadecimal values. May be null. + +=cut + +sub ut_hexn { + my($self, $field) = @_; + $self->getfield($field) =~ /^([\da-fA-F]*)$/ + or return "Illegal (hex) $field: ". $self->getfield($field); + $self->setfield($field, uc($1)); + ''; +} =item ut_ip COLUMN Check/untaint ip addresses. IPv4 only for now. @@ -1432,6 +1686,92 @@ sub ut_ipn { } } +=item ut_coord COLUMN [ LOWER [ UPPER ] ] + +Check/untaint coordinates. +Accepts the following forms: +DDD.DDDDD +-DDD.DDDDD +DDD MM.MMM +-DDD MM.MMM +DDD MM SS +-DDD MM SS +DDD MM MMM +-DDD MM MMM + +The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous. +The latter form (that is, the MMM are thousands of minutes) is +assumed if the "MMM" is exactly three digits or two digits > 59. + +To be safe, just use the DDD.DDDDD form. + +If LOWER or UPPER are specified, then the coordinate is checked +for lower and upper bounds, respectively. + +=cut + +sub ut_coord { + + my ($self, $field) = (shift, shift); + + my $lower = shift if scalar(@_); + my $upper = shift if scalar(@_); + my $coord = $self->getfield($field); + my $neg = $coord =~ s/^(-)//; + + my ($d, $m, $s) = (0, 0, 0); + + if ( + (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) || + (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) || + (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/)) + ) { + $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60); + $m = $m / 60; + if ($m > 59) { + return "Invalid (coordinate with minutes > 59) $field: " + . $self->getfield($field); + } + + $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s); + + if (defined($lower) and ($coord < $lower)) { + return "Invalid (coordinate < $lower) $field: " + . $self->getfield($field);; + } + + if (defined($upper) and ($coord > $upper)) { + return "Invalid (coordinate > $upper) $field: " + . $self->getfield($field);; + } + + $self->setfield($field, $coord); + return ''; + } + + return "Invalid (coordinate) $field: " . $self->getfield($field); + +} + +=item ut_coordn COLUMN [ LOWER [ UPPER ] ] + +Same as ut_coord, except optionally null. + +=cut + +sub ut_coordn { + + my ($self, $field) = (shift, shift); + + if ($self->getfield($field) =~ /^$/) { + return ''; + } else { + return $self->ut_coord($field, @_); + } + +} + + =item ut_domain COLUMN Check/untaint host and domain names. @@ -1470,22 +1810,40 @@ Check/untaint zip codes. =cut +my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit... + sub ut_zip { my( $self, $field, $country ) = @_; + if ( $country eq 'US' ) { - $self->getfield($field) =~ /\s*(\d{5}(\-\d{4})?)\s*$/ + + $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/ or return gettext('illegal_zip'). " $field for country $country: ". $self->getfield($field); - $self->setfield($field,$1); + $self->setfield($field, $1); + + } elsif ( $country eq 'CA' ) { + + $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i + or return gettext('illegal_zip'). " $field for country $country: ". + $self->getfield($field); + $self->setfield($field, "$1 $2"); + } else { - if ( $self->getfield($field) =~ /^\s*$/ ) { + + if ( $self->getfield($field) =~ /^\s*$/ + && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries ) + ) + { $self->setfield($field,''); } else { $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/ or return gettext('illegal_zip'). " $field: ". $self->getfield($field); $self->setfield($field,$1); } + } + ''; } @@ -1550,6 +1908,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"; @@ -1569,6 +1928,36 @@ sub ut_foreign_keyn { : ''; } +=item ut_agentnum_acl + +Checks this column as an agentnum, taking into account the current users's +ACLs. + +=cut + +sub ut_agentnum_acl { + my( $self, $field, $null_acl ) = @_; + + my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum'); + return "Illegal agentnum: $error" if $error; + + my $curuser = $FS::CurrentUser::CurrentUser; + + if ( $self->$field() ) { + + return "Access denied" + unless $curuser->agentnum($self->$field()); + + } else { + + return "Access denied" + unless $curuser->access_right($null_acl); + + } + + ''; + +} =item virtual_fields [ TABLE ] @@ -1591,7 +1980,8 @@ sub virtual_fields { "WHERE dbtable = '$table'"; my $dbh = dbh; my $result = $dbh->selectcol_arrayref($query); - confess $dbh->errstr if $dbh->err; + confess "Error executing virtual fields query: $query: ". $dbh->errstr + if $dbh->err; $virtual_fields_cache{$table} = $result; } @@ -1619,8 +2009,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 @@ -1638,59 +2026,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 '' && $column_type =~ /^int/ ) { - if ( $nullable ) { - 'NULL'; - } else { - 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 @@ -1714,32 +2049,16 @@ sub vfieldpart_hashref { } +=item encrypt($value) -=item hfields TABLE +Encrypts the credit card using a combination of PK to encrypt and uuencode to armour. -This is deprecated. Don't use it. +Returns the encrypted string. -It returns a hash-type list with the fields of this record's table set true. +You should generally not have to worry about calling this, as the system handles this for you. =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 encrypt { my ($self, $value) = @_; my $encrypted; @@ -1763,17 +2082,32 @@ sub encrypt { return $encrypted; } +=item is_encrypted($value) + +Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status. + +=cut + + sub is_encrypted { my ($self, $value) = @_; # Possible Bug - Some work may be required here.... - if (length($value) > 80) { + if ($value =~ /^M/ && length($value) > 80) { return 1; } else { return 0; } } +=item decrypt($value) + +Uses the private key to decrypt the string. Returns the decryoted string or undef on failure. + +You should generally not have to worry about calling this, as the system handles this for you. + +=cut + sub decrypt { my ($self,$value) = @_; my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted. @@ -1781,7 +2115,8 @@ sub decrypt { $self->loadRSA; if (ref($rsa_decrypt) =~ /::RSA/) { my $encrypted = unpack ("u*", $value); - $decrypted = unpack("Z*", $rsa_decrypt->decrypt($encrypted)); + $decrypted = unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)}); + if ($@) {warn "Decryption Failed"}; } } return $decrypted; @@ -1792,7 +2127,7 @@ sub loadRSA { #Initialize the Module $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default - if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') { + if ($conf->exists('encryptionmodule') && $conf->config_binary('encryptionmodule') ne '') { $rsa_module = $conf->config('encryptionmodule'); } @@ -1801,18 +2136,133 @@ sub loadRSA { $rsa_loaded++; } # Initialize Encryption - if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') { + if ($conf->exists('encryptionpublickey') && $conf->config_binary('encryptionpublickey') ne '') { my $public_key = join("\n",$conf->config('encryptionpublickey')); $rsa_encrypt = $rsa_module->new_public_key($public_key); } # Intitalize Decryption - if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') { + if ($conf->exists('encryptionprivatekey') && $conf->config_binary('encryptionprivatekey') ne '') { my $private_key = join("\n",$conf->config('encryptionprivatekey')); $rsa_decrypt = $rsa_module->new_private_key($private_key); } } +=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 { @@ -1826,6 +2276,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