X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=15636af9c14201926748d7afcc83dd51fa5ef925;hp=3511fe7f018edcd71f015e3f513974fe9e0daded;hb=63973c641c4be00765fa27e55c57cc5b9aa4da19;hpb=811c95da18776232da103fd445e2def019f98d5b diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index 3511fe7f0..15636af9c 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -2,10 +2,12 @@ package FS::Record; use strict; use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG - $conf $conf_encryption $me %virtual_fields_cache + $conf $conf_encryption $money_char $lat_lower $lon_upper + $me $nowarn_identical $nowarn_classload $no_update_diff $no_check_foreign + @encrypt_payby ); use Exporter; use Carp qw(carp cluck croak confess); @@ -16,12 +18,13 @@ use Text::CSV_XS; use File::Slurp qw( slurp ); use DBI qw(:sql_types); use DBIx::DBSchema 0.38; -use FS::UID qw(dbh getotaker datasrc driver_name); +use FS::UID qw(dbh datasrc driver_name); use FS::CurrentUser; use FS::Schema qw(dbdef); use FS::SearchCache; use FS::Msgcat qw(gettext); use NetAddr::IP; # for validation +use Data::Dumper; #use FS::Conf; #dependency loop bs, in install_callback below instead use FS::part_virtual_field; @@ -30,10 +33,13 @@ use Tie::IxHash; @ISA = qw(Exporter); +@encrypt_payby = qw( CARD DCRD CHEK DCHK ); + #export dbdef for now... everything else expects to find it here @EXPORT_OK = qw( dbh fields hfields qsearch qsearchs dbdef jsearch str2time_sql str2time_sql_closing regexp_sql not_regexp_sql concat_sql + midnight_sql ); $DEBUG = 0; @@ -52,17 +58,25 @@ 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'); + $money_char = $conf->config('money_char') || '$'; + my $nw_coords = $conf->exists('geocode-require_nw_coordinates'); + $lat_lower = $nw_coords ? 1 : -90; + $lon_upper = $nw_coords ? -1 : 180; + $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc; + if ( driver_name eq 'Pg' ) { eval "use DBD::Pg ':pg_types'"; die $@ if $@; } else { eval "sub PG_BYTEA { die 'guru meditation #9: calling PG_BYTEA when not running Pg?'; }"; } + } ); =head1 NAME @@ -268,7 +282,7 @@ sub _bind_type { my $bind_type = { TYPE => SQL_VARCHAR }; - if ( $type =~ /(big)?(int|serial)/i && $value =~ /^\d+(\.\d+)?$/ ) { + if ( $type =~ /(big)?(int|serial)/i && $value =~ /^-?\d+(\.\d+)?$/ ) { $bind_type = { TYPE => SQL_INTEGER }; @@ -375,22 +389,12 @@ sub qsearch { my $pkey = $dbdef_table->primary_key; my @real_fields = grep exists($record->{$_}), real_fields($table); - my @virtual_fields; - 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" - unless $nowarn_classload; - @virtual_fields = (); - } my $statement .= "SELECT $select FROM $stable"; $statement .= " $addl_from" if $addl_from; - if ( @real_fields or @virtual_fields ) { + if ( @real_fields ) { $statement .= ' WHERE '. join(' AND ', - get_real_fields($table, $record, \@real_fields) , - get_virtual_fields($table, $pkey, $record, \@virtual_fields), - ); + get_real_fields($table, $record, \@real_fields)); } $statement .= " $extra_sql" if defined($extra_sql); @@ -454,23 +458,19 @@ sub qsearch { # grep defined( $record->{$_} ) && $record->{$_} ne '', @fields # ) or croak "Error executing \"$statement\": ". $sth->errstr; - $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr; + my $ok = $sth->execute; + if (!$ok) { + my $error = "Error executing \"$statement\""; + $error .= ' (' . join(', ', map {"'$_'"} @value) . ')' if @value; + $error .= ': '. $sth->errstr; + croak $error; + } - # virtual fields and blessings are nonsense in a heterogeneous UNION, right? my $table = $stable[0]; my $pkey = ''; $table = '' if grep { $_ ne $table } @stable; $pkey = dbdef->table($table)->primary_key if $table; - my @virtual_fields = (); - if ( eval 'scalar(@FS::'. $table. '::ISA);' ) { - @virtual_fields = "FS::$table"->virtual_fields; - } else { - cluck "warning: FS::$table not loaded; virtual fields not returned either" - unless $nowarn_classload; - @virtual_fields = (); - } - my %result; tie %result, "Tie::IxHash"; my @stuff = @{ $sth->fetchall_arrayref( {} ) }; @@ -482,28 +482,6 @@ sub qsearch { $sth->finish; - if ( keys(%result) and @virtual_fields ) { - $statement = - "SELECT virtual_field.recnum, part_virtual_field.name, ". - "virtual_field.value ". - "FROM part_virtual_field JOIN virtual_field USING (vfieldpart) ". - "WHERE part_virtual_field.dbtable = '$table' AND ". - "virtual_field.recnum IN (". - join(',', keys(%result)). ") AND part_virtual_field.name IN ('". - join(q!', '!, @virtual_fields) . "')"; - warn "[debug]$me $statement\n" if $DEBUG > 1; - $sth = $dbh->prepare($statement) or croak "$dbh->errstr doing $statement"; - $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr; - - foreach (@{ $sth->fetchall_arrayref({}) }) { - my $recnum = $_->{recnum}; - my $name = $_->{name}; - my $value = $_->{value}; - if (exists($result{$recnum})) { - $result{$recnum}->{$name} = $value; - } - } - } my @return; if ( eval 'scalar(@FS::'. $table. '::ISA);' ) { if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) { @@ -531,6 +509,11 @@ sub qsearch { && eval 'defined(@FS::'. $table . '::encrypted_fields)' ) { foreach my $record (@return) { foreach my $field (eval '@FS::'. $table . '::encrypted_fields') { + next if $field eq 'payinfo' + && ($record->isa('FS::payinfo_transaction_Mixin') + || $record->isa('FS::payinfo_Mixin') ) + && $record->payby + && !grep { $record->payby eq $_ } @encrypt_payby; # Set it directly... This may cause a problem in the future... $record->setfield($field, $record->decrypt($record->getfield($field))); } @@ -548,50 +531,6 @@ sub qsearch { ## 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; @@ -645,6 +584,8 @@ sub get_real_fields { qq-( $column $op "" )-; } } + } elsif ( $op eq '!=' ) { + qq-( $column IS NULL OR $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 @@ -966,10 +907,12 @@ sub insert { my $error = $self->check; return $error if $error; - #single-field unique keys are given a value if false + #single-field non-null unique keys are given a value if empty #(like MySQL's AUTO_INCREMENT or Pg SERIAL) foreach ( $self->dbdef_table->unique_singles) { - $self->unique($_) unless $self->getfield($_); + next if $self->getfield($_); + next if $self->dbdef_table->column($_)->null eq 'NULL'; + $self->unique($_); } #and also the primary key, if the database isn't going to @@ -999,7 +942,12 @@ sub insert { && $conf->exists('encryption') ) { foreach my $field (eval '@FS::'. $table . '::encrypted_fields') { - $self->{'saved'} = $self->getfield($field); + next if $field eq 'payinfo' + && ($self->isa('FS::payinfo_transaction_Mixin') + || $self->isa('FS::payinfo_Mixin') ) + && $self->payby + && !grep { $self->payby eq $_ } @encrypt_payby; + $saved->{$field} = $self->getfield($field); $self->setfield($field, $self->encrypt($self->getfield($field))); } } @@ -1097,34 +1045,6 @@ sub insert { } - my @virtual_fields = - grep defined($self->getfield($_)) && $self->getfield($_) ne "", - $self->virtual_fields; - if (@virtual_fields) { - my %v_values = map { $_, $self->getfield($_) } @virtual_fields; - - my $vfieldpart = $self->vfieldpart_hashref; - - my $v_statement = "INSERT INTO virtual_field(recnum, vfieldpart, value) ". - "VALUES (?, ?, ?)"; - - my $v_sth = dbh->prepare($v_statement) or do { - dbh->rollback if $FS::UID::AutoCommit; - return dbh->errstr; - }; - - foreach (keys(%v_values)) { - $v_sth->execute($self->getfield($primary_key), - $vfieldpart->{$_}, - $v_values{$_}) - or do { - dbh->rollback if $FS::UID::AutoCommit; - return $v_sth->errstr; - }; - } - } - - my $h_sth; if ( defined dbdef->table('h_'. $table) ) { my $h_statement = $self->_h_statement('insert'); @@ -1196,17 +1116,6 @@ sub delete { } my $primary_key = $self->dbdef_table->primary_key; - my $v_sth; - my @del_vfields; - my $vfp = $self->vfieldpart_hashref; - foreach($self->virtual_fields) { - next if $self->getfield($_) eq ''; - unless(@del_vfields) { - my $st = "DELETE FROM virtual_field WHERE recnum = ? AND vfieldpart = ?"; - $v_sth = dbh->prepare($st) or return dbh->errstr; - } - push @del_vfields, $_; - } local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; @@ -1218,9 +1127,6 @@ sub delete { my $rc = $sth->execute or return $sth->errstr; #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0"; $h_sth->execute or return $h_sth->errstr if $h_sth; - $v_sth->execute($self->getfield($primary_key), $vfp->{$_}) - or return $v_sth->errstr - foreach (@del_vfields); dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit; @@ -1279,6 +1185,11 @@ sub replace { && scalar( eval '@FS::'. $new->table . '::encrypted_fields') ) { foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') { + next if $field eq 'payinfo' + && ($new->isa('FS::payinfo_transaction_Mixin') + || $new->isa('FS::payinfo_Mixin') ) + && $new->payby + && !grep { $new->payby eq $_ } @encrypt_payby; $saved->{$field} = $new->getfield($field); $new->setfield($field, $new->encrypt($new->getfield($field))); } @@ -1289,7 +1200,9 @@ sub replace { ? ($_, $new->getfield($_)) : () } $old->fields; unless (keys(%diff) || $no_update_diff ) { - carp "[warning]$me $new -> replace $old: records identical" + carp "[warning]$me ". ref($new)."->replace ". + ( $primary_key ? "$primary_key ".$new->get($primary_key) : '' ). + ": records identical" unless $nowarn_identical; return ''; } @@ -1344,44 +1257,6 @@ sub replace { $h_new_sth = ''; } - # For virtual fields we have three cases with different SQL - # statements: add, replace, delete - my $v_add_sth; - my $v_rep_sth; - my $v_del_sth; - my (@add_vfields, @rep_vfields, @del_vfields); - my $vfp = $old->vfieldpart_hashref; - foreach(grep { exists($diff{$_}) } $new->virtual_fields) { - if($diff{$_} eq '') { - # Delete - unless(@del_vfields) { - my $st = "DELETE FROM virtual_field WHERE recnum = ? ". - "AND vfieldpart = ?"; - warn "[debug]$me $st\n" if $DEBUG > 2; - $v_del_sth = dbh->prepare($st) or return dbh->errstr; - } - push @del_vfields, $_; - } elsif($old->getfield($_) eq '') { - # Add - unless(@add_vfields) { - my $st = "INSERT INTO virtual_field (value, recnum, vfieldpart) ". - "VALUES (?, ?, ?)"; - warn "[debug]$me $st\n" if $DEBUG > 2; - $v_add_sth = dbh->prepare($st) or return dbh->errstr; - } - push @add_vfields, $_; - } else { - # Replace - unless(@rep_vfields) { - my $st = "UPDATE virtual_field SET value = ? ". - "WHERE recnum = ? AND vfieldpart = ?"; - warn "[debug]$me $st\n" if $DEBUG > 2; - $v_rep_sth = dbh->prepare($st) or return dbh->errstr; - } - push @rep_vfields, $_; - } - } - local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; local $SIG{QUIT} = 'IGNORE'; @@ -1394,23 +1269,6 @@ sub replace { $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth; $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth; - $v_del_sth->execute($old->getfield($primary_key), - $vfp->{$_}) - or return $v_del_sth->errstr - foreach(@del_vfields); - - $v_add_sth->execute($new->getfield($_), - $old->getfield($primary_key), - $vfp->{$_}) - or return $v_add_sth->errstr - foreach(@add_vfields); - - $v_rep_sth->execute($new->getfield($_), - $old->getfield($primary_key), - $vfp->{$_}) - or return $v_rep_sth->errstr - foreach(@rep_vfields); - dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit; # Now that it has been saved, reset the encrypted fields so that $new @@ -1452,35 +1310,49 @@ sub rep { =item check -Checks virtual fields (using check_blocks). Subclasses should still provide -a check method to validate real fields, foreign keys, etc., and call this -method via $self->SUPER::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. + +=cut + +sub check { + my $self = shift; + foreach my $field ($self->virtual_fields) { + my $error = $self->ut_textn($field); + return $error if $error; + } + ''; +} -(FIXME: Should this method try to make sure that it I being called from -a subclass's check method, to keep the current semantics as far as possible?) +=item virtual_fields [ TABLE ] + +Returns a list of virtual fields defined for the table. This should not +be exported, and should only be called as an instance or class method. =cut -sub check { - #confess "FS::Record::check not implemented; supply one in subclass!"; +sub virtual_fields { my $self = shift; + my $table; + $table = $self->table or confess "virtual_fields called on non-table"; - foreach my $field ($self->virtual_fields) { - for ($self->getfield($field)) { - # See notes on check_block in FS::part_virtual_field. - eval $self->pvf($field)->check_block; - if ( $@ ) { - #this is bad, probably want to follow the stack backtrace up and see - #wtf happened - my $err = "Fatal error checking $field for $self"; - cluck "$err: $@"; - return "$err (see log for backtrace): $@"; + confess "Unknown table $table" unless dbdef->table($table); - } - $self->setfield($field, $_); - } + return () unless dbdef->table('part_virtual_field'); + + unless ( $virtual_fields_cache{$table} ) { + my $concat = [ "'cf_'", "name" ]; + my $query = "SELECT ".concat_sql($concat).' from part_virtual_field ' . + "WHERE dbtable = '$table'"; + my $dbh = dbh; + my $result = $dbh->selectcol_arrayref($query); + confess "Error executing virtual fields query: $query: ". $dbh->errstr + if $dbh->err; + $virtual_fields_cache{$table} = $result; } - ''; + + @{$virtual_fields_cache{$table}}; + } =item process_batch_import JOB OPTIONS_HASHREF PARAMS @@ -1585,6 +1457,7 @@ sub process_batch_import { format_sep_chars => $opt->{format_sep_chars}, format_fixedlength_formats => $opt->{format_fixedlength_formats}, format_xml_formats => $opt->{format_xml_formats}, + format_asn_formats => $opt->{format_asn_formats}, format_row_callbacks => $opt->{format_row_callbacks}, #per-import job => $job, @@ -1667,8 +1540,9 @@ sub batch_import { my $file = $param->{file}; my $params = $param->{params} || {}; - my( $type, $header, $sep_char, $fixedlength_format, - $xml_format, $row_callback, @fields ); + my( $type, $header, $sep_char, + $fixedlength_format, $xml_format, $asn_format, + $row_callback, @fields ); my $postinsert_callback = ''; $postinsert_callback = $param->{'postinsert_callback'} @@ -1706,6 +1580,11 @@ sub batch_import { ? $param->{'format_xml_formats'}{ $param->{'format'} } : ''; + $asn_format = + $param->{'format_asn_formats'} + ? $param->{'format_asn_formats'}{ $param->{'format'} } + : ''; + $row_callback = $param->{'format_row_callbacks'} ? $param->{'format_row_callbacks'}{ $param->{'format'} } @@ -1745,11 +1624,12 @@ sub batch_import { my $count; my $parser; my @buffer = (); + my $asn_header_buffer; if ( $type eq 'csv' || $type eq 'fixedlength' ) { if ( $type eq 'csv' ) { - my %attr = (); + my %attr = ( 'binary' => 1, ); $attr{sep_char} = $sep_char if $sep_char; $parser = new Text::CSV_XS \%attr; @@ -1786,7 +1666,9 @@ sub batch_import { $count++; $row = $header || 0; + } elsif ( $type eq 'xml' ) { + # FS::pay_batch eval "use XML::Simple;"; die $@ if $@; @@ -1802,6 +1684,26 @@ sub batch_import { $rows = $rows->{$_} foreach @$xmlrow; $rows = [ $rows ] if ref($rows) ne 'ARRAY'; $count = @buffer = @$rows; + + } elsif ( $type eq 'asn.1' ) { + + eval "use Convert::ASN1"; + die $@ if $@; + + my $asn = Convert::ASN1->new; + $asn->prepare( $asn_format->{'spec'} ) or die $asn->error; + + $parser = $asn->find( $asn_format->{'macro'} ) or die $asn->error; + + my $data = slurp($file); + my $asn_output = $parser->decode( $data ) + or die "No ". $asn_format->{'macro'}. " found\n"; + + $asn_header_buffer = &{ $asn_format->{'header_buffer'} }( $asn_output ); + + my $rows = &{ $asn_format->{'arrayref'} }( $asn_output ); + $count = @buffer = @$rows; + } else { die "Unknown file type $type\n"; } @@ -1845,6 +1747,7 @@ sub batch_import { while (1) { my @columns = (); + my %hash = %$params; if ( $type eq 'csv' ) { last unless scalar(@buffer); @@ -1853,10 +1756,12 @@ sub batch_import { next if $line =~ /^\s*$/; #skip empty lines $line = &{$row_callback}($line) if $row_callback; + + next if $line =~ /^\s*$/; #skip empty lines $parser->parse($line) or do { $dbh->rollback if $oldAutoCommit; - return "can't parse: ". $parser->error_input(); + return "can't parse: ". $parser->error_input() . " " . $parser->error_diag; }; @columns = $parser->fields(); @@ -1879,16 +1784,27 @@ sub batch_import { #warn $z++. ": $_\n" for @columns; } elsif ( $type eq 'xml' ) { + # $parser = [ 'Column0Key', 'Column1Key' ... ] last unless scalar(@buffer); my $row = shift @buffer; @columns = @{ $row }{ @$parser }; + + } elsif ( $type eq 'asn.1' ) { + + last unless scalar(@buffer); + my $row = shift @buffer; + &{ $asn_format->{row_callback} }( $row, $asn_header_buffer ) + if $asn_format->{row_callback}; + foreach my $key ( keys %{ $asn_format->{map} } ) { + $hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer ); + } + } else { die "Unknown file type $type\n"; } my @later = (); - my %hash = %$params; foreach my $field ( @fields ) { @@ -1925,7 +1841,7 @@ sub batch_import { next if exists( $param->{skiprow} ); if ( $preinsert_callback ) { - my $error = &{$postinsert_callback}($record, $param); + my $error = &{$preinsert_callback}($record, $param); if ( $error ) { $dbh->rollback if $oldAutoCommit; return "preinsert_callback error". ( $line ? " for $line" : '' ). @@ -1984,7 +1900,7 @@ sub _h_statement { ; # If we're encrypting then don't store the payinfo in the history - if ( $conf && $conf->exists('encryption') ) { + if ( $conf && $conf->exists('encryption') && $self->table ne 'banned_pay' ) { @fields = grep { $_ ne 'payinfo' } @fields; } @@ -1993,7 +1909,11 @@ sub _h_statement { "INSERT INTO h_". $self->table. " ( ". join(', ', qw(history_date history_user history_action), @fields ). ") VALUES (". - join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values). + join(', ', $time, + dbh->quote( $FS::CurrentUser::CurrentUser->username ), + dbh->quote($action), + @values + ). ")" ; } @@ -2024,11 +1944,6 @@ sub unique { #warn "field $field is tainted" if is_tainted($field); my($counter) = new File::CounterFile "$table.$field",0; -# hack for web demo -# getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!"; -# my($user)=$1; -# my($counter) = new File::CounterFile "$user/$table.$field",0; -# endhack my $index = $counter->inc; $index = $counter->inc while qsearchs($table, { $field=>$index } ); @@ -2183,11 +2098,18 @@ 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) =~ /^\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); + + if ( $self->getfield($field) eq '' ) { + $self->setfield($field, 0); + } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{1})\s*$/ ) { + #handle one decimal place without barfing out + $self->setfield($field, ( ($1||''). ($2||''). ($3.'0') ) || 0); + } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ ) { + $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0); + } else { + return "Illegal (money) $field: ". $self->getfield($field); + } + ''; } @@ -2222,7 +2144,7 @@ sub ut_text { #warn "notexist ". \¬exist. "\n"; #warn "AUTOLOAD ". \&AUTOLOAD. "\n"; $self->getfield($field) - =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>]+)$/ + =~ /^([\wô \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/ or return gettext('illegal_or_empty_text'). " $field: ". $self->getfield($field); $self->setfield($field,$1); @@ -2232,7 +2154,7 @@ sub ut_text { =item ut_textn COLUMN Check/untaint text. Alphanumerics, spaces, and the following punctuation -symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / +symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < > May be null. If there is an error, returns the error, otherwise returns false. =cut @@ -2363,6 +2285,42 @@ sub ut_hexn { $self->setfield($field, uc($1)); ''; } + +=item ut_mac_addr COLUMN + +Check/untaint mac addresses. May be null. + +=cut + +sub ut_mac_addr { + my($self, $field) = @_; + + my $mac = $self->get($field); + $mac =~ s/\s+//g; + $mac =~ s/://g; + $self->set($field, $mac); + + my $e = $self->ut_hex($field); + return $e if $e; + + return "Illegal (mac address) $field: ". $self->getfield($field) + unless length($self->getfield($field)) == 12; + + ''; + +} + +=item ut_mac_addrn COLUMN + +Check/untaint mac addresses. May be null. + +=cut + +sub ut_mac_addrn { + my($self, $field) = @_; + ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field); +} + =item ut_ip COLUMN Check/untaint ip addresses. IPv4 only for now, though ::1 is auto-translated @@ -2451,11 +2409,17 @@ 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($lower, $upper); + if ( $field =~ /latitude/ ) { + $lower = $lat_lower; + $upper = 90; + } elsif ( $field =~ /longitude/ ) { + $lower = -180; + $upper = $lon_upper; + } + my $coord = $self->getfield($field); my $neg = $coord =~ s/^(-)//; @@ -2503,7 +2467,7 @@ sub ut_coordn { my ($self, $field) = (shift, shift); - if ($self->getfield($field) =~ /^$/) { + if ($self->getfield($field) =~ /^\s*$/) { return ''; } else { return $self->ut_coord($field, @_); @@ -2511,10 +2475,9 @@ sub ut_coordn { } - =item ut_domain COLUMN -Check/untaint host and domain names. +Check/untaint host and domain names. May not be null. =cut @@ -2522,11 +2485,27 @@ sub ut_domain { my( $self, $field ) = @_; #$self->getfield($field) =~/^(\w+\.)*\w+$/ $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/ - or return "Illegal (domain) $field: ". $self->getfield($field); + or return "Illegal (hostname) $field: ". $self->getfield($field); $self->setfield($field,$1); ''; } +=item ut_domainn COLUMN + +Check/untaint host and domain names. May be null. + +=cut + +sub ut_domainn { + my( $self, $field ) = @_; + if ( $self->getfield($field) =~ /^()$/ ) { + $self->setfield($field,''); + ''; + } else { + $self->ut_domain($field); + } +} + =item ut_name COLUMN Check/untaint proper names; allows alphanumerics, spaces and the following @@ -2541,10 +2520,29 @@ sub ut_name { # warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n"; $self->getfield($field) =~ /^([\w \,\.\-\']+)$/ or return gettext('illegal_name'). " $field: ". $self->getfield($field); - $self->setfield($field,$1); + my $name = $1; + $name =~ s/^\s+//; + $name =~ s/\s+$//; + $name =~ s/\s+/ /g; + $self->setfield($field, $name); ''; } +=item ut_namen COLUMN + +Check/untaint proper names; allows alphanumerics, spaces and the following +punctuation: , . - ' + +May not be null. + +=cut + +sub ut_namen { + my( $self, $field ) = @_; + return $self->setfield($field, '') if $self->getfield($field) =~ /^$/; + $self->ut_name($field); +} + =item ut_zip COLUMN Check/untaint zip codes. @@ -2578,7 +2576,7 @@ sub ut_zip { { $self->setfield($field,''); } else { - $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/ + $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/ or return gettext('illegal_zip'). " $field: ". $self->getfield($field); $self->setfield($field,$1); } @@ -2653,6 +2651,22 @@ sub ut_enumn { : ''; } +=item ut_flag COLUMN + +Check/untaint a column if it contains either an empty string or 'Y'. This +is the standard form for boolean flags in Freeside. + +=cut + +sub ut_flag { + my( $self, $field ) = @_; + my $value = uc($self->getfield($field)); + if ( $value eq '' or $value eq 'Y' ) { + $self->setfield($field, $value); + return ''; + } + return "Illegal (flag) field $field: $value"; +} =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN @@ -2717,40 +2731,9 @@ sub ut_agentnum_acl { } -=item virtual_fields [ TABLE ] - -Returns a list of virtual fields defined for the table. This should not -be exported, and should only be called as an instance or class method. - -=cut - -sub virtual_fields { - my $self = shift; - my $table; - $table = $self->table or confess "virtual_fields called on non-table"; - - confess "Unknown table $table" unless dbdef->table($table); - - return () unless dbdef->table('part_virtual_field'); - - unless ( $virtual_fields_cache{$table} ) { - my $query = 'SELECT name from part_virtual_field ' . - "WHERE dbtable = '$table'"; - my $dbh = dbh; - my $result = $dbh->selectcol_arrayref($query); - confess "Error executing virtual fields query: $query: ". $dbh->errstr - if $dbh->err; - $virtual_fields_cache{$table} = $result; - } - - @{$virtual_fields_cache{$table}}; - -} - - =item fields [ TABLE ] -This is a wrapper for real_fields and virtual_fields. Code that called +This is a wrapper for real_fields. Code that called fields before should probably continue to call fields. =cut @@ -2764,48 +2747,9 @@ sub fields { $table = $something; $something = "FS::$table"; } - return (real_fields($table), $something->virtual_fields()); -} - -=item pvf FIELD_NAME - -Returns the FS::part_virtual_field object corresponding to a field in the -record (specified by FIELD_NAME). - -=cut - -sub pvf { - my ($self, $name) = (shift, shift); - - if(grep /^$name$/, $self->virtual_fields) { - return qsearchs('part_virtual_field', { dbtable => $self->table, - name => $name } ); - } - '' + return (real_fields($table)); } -=item vfieldpart_hashref TABLE - -Returns a hashref of virtual field names and vfieldparts applicable to the given -TABLE. - -=cut - -sub vfieldpart_hashref { - my $self = shift; - my $table = $self->table; - - return {} unless dbdef->table('part_virtual_field'); - - my $dbh = dbh; - my $statement = "SELECT vfieldpart, name FROM part_virtual_field WHERE ". - "dbtable = '$table'"; - my $sth = $dbh->prepare($statement); - $sth->execute or croak "Execution of '$statement' failed: ".$dbh->errstr; - return { map { $_->{name}, $_->{vfieldpart} } - @{$sth->fetchall_arrayref({})} }; - -} =item encrypt($value) @@ -2965,6 +2909,22 @@ sub scalar_sql { defined($scalar) ? $scalar : ''; } +=item count [ WHERE ] + +Convenience method for the common case of "SELECT COUNT(*) FROM table", +with optional WHERE. Must be called as method on a class with an +associated table. + +=cut + +sub count { + my($self, $where) = (shift, shift); + 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); +} + =back =head1 SUBROUTINES @@ -2986,6 +2946,29 @@ sub real_fields { $table_obj->columns; } +=item pvf FIELD_NAME + +Returns the FS::part_virtual_field object corresponding to a field in the +record (specified by FIELD_NAME). + +=cut + +sub pvf { + my ($self, $name) = (shift, shift); + + if(grep /^$name$/, $self->virtual_fields) { + $name =~ s/^cf_//; + my $concat = [ "'cf_'", "name" ]; + return qsearchs({ table => 'part_virtual_field', + hashref => { dbtable => $self->table, + name => $name + }, + select => 'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name', + }); + } + '' +} + =item _quote VALUE, TABLE, COLUMN This is an internal function used to construct SQL statements. It returns @@ -3152,7 +3135,7 @@ sub not_regexp_sql { =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF -Returns the items concatendated based on database type, using "CONCAT()" for +Returns the items concatenated based on database type, using "CONCAT()" for mysql and " || " for Pg and other databases. You can pass an optional driver name such as "Pg", "mysql" or @@ -3173,6 +3156,24 @@ sub concat_sql { } +=item midnight_sql DATE + +Returns an SQL expression to convert DATE (a unix timestamp) to midnight +on that day in the system timezone, using the default driver name. + +=cut + +sub midnight_sql { + my $driver = driver_name; + my $expr = shift; + if ( $driver =~ /^mysql/i ) { + "UNIX_TIMESTAMP(DATE(FROM_UNIXTIME($expr)))"; + } + else { + "EXTRACT( EPOCH FROM DATE(TO_TIMESTAMP($expr)) )"; + } +} + =back =head1 BUGS