use strict;
use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG
%virtual_fields_cache
- $conf $conf_encryption $money_char
+ $conf $conf_encryption $money_char $lat_lower $lon_upper
$me
$nowarn_identical $nowarn_classload
$no_update_diff $no_check_foreign
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;
@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;
$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
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 };
# 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;
+ }
my $table = $stable[0];
my $pkey = '';
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
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
|| $self->isa('FS::payinfo_Mixin') )
&& $self->payby
&& !grep { $self->payby eq $_ } @encrypt_payby;
- $self->{'saved'} = $self->getfield($field);
+ $saved->{$field} = $self->getfield($field);
$self->setfield($field, $self->encrypt($self->getfield($field)));
}
}
? ($_, $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 '';
}
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,
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'}
? $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'} }
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;
$count++;
$row = $header || 0;
+
} elsif ( $type eq 'xml' ) {
+
# FS::pay_batch
eval "use XML::Simple;";
die $@ if $@;
$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";
}
while (1) {
my @columns = ();
+ my %hash = %$params;
if ( $type eq 'csv' ) {
last unless scalar(@buffer);
#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 ) {
;
# 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;
}
"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
+ ).
")"
;
}
#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 } );
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);
+ }
+
'';
}
#warn "notexist ". \¬exist. "\n";
#warn "AUTOLOAD ". \&AUTOLOAD. "\n";
$self->getfield($field)
- =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/
+ =~ /^([\wรด \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/
or return gettext('illegal_or_empty_text'). " $field: ".
$self->getfield($field);
$self->setfield($field,$1);
=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
$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
=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/^(-)//;
my ($self, $field) = (shift, shift);
- if ($self->getfield($field) =~ /^$/) {
+ if ($self->getfield($field) =~ /^\s*$/) {
return '';
} else {
return $self->ut_coord($field, @_);
}
-
=item ut_domain COLUMN
-Check/untaint host and domain names.
+Check/untaint host and domain names. May not be null.
=cut
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
# 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.
{
$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);
}
: '';
}
+=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
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
=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
}
+=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
projects / freeside.git / blobdiff