#export dbdef for now... everything else expects to find it here
our @EXPORT_OK = qw(
dbh fields hfields qsearch qsearchs dbdef jsearch
- str2time_sql str2time_sql_closing regexp_sql not_regexp_sql concat_sql
+ str2time_sql str2time_sql_closing regexp_sql not_regexp_sql
+ concat_sql group_concat_sql
midnight_sql
);
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;
$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');
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);
push @statement, $statement;
warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
-
foreach my $field (
grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
$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 ) {
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
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]) : ();
my $method = '';
if ( scalar( @{$fk->columns} ) == 1 ) {
- if ( ! @{$fk->references} || $fk->columns->[0] eq $fk->references->[0] ){
+ if ( ! defined($fk->references)
+ || ! @{$fk->references}
+ || $fk->columns->[0] eq $fk->references->[0]
+ ) {
$method = $fk->table;
} else {
#some sort of hint in the table.pm or schema for methods not named
my $method = '';
if ( scalar( @{$fk->columns} ) == 1 ) {
- if ( ! @{$fk->references} || $fk->columns->[0] eq $fk->references->[0] ){
+ if ( ! defined($fk->references)
+ || ! @{$fk->references}
+ || $fk->columns->[0] eq $fk->references->[0]
+ ) {
$method = $f_table;
} else {
#some sort of hint in the table.pm or schema for methods not named
$self->{'Hash'};
}
-#fallback
+#fallbacks/generics
+
sub API_getinfo {
my $self = shift;
+{ ( map { $_=>$self->$_ } $self->fields ),
};
}
+sub API_insert {
+ my( $class, %opt ) = @_;
+ my $table = $class->table;
+ my $self = $class->new( { map { $_ => $opt{$_} } fields($table) } );
+ my $error = $self->insert;
+ return +{ 'error' => $error } if $error;
+ my $pkey = $self->pkey;
+ return +{ 'error' => '',
+ 'primary_key' => $pkey,
+ $pkey => $self->$pkey,
+ };
+}
+
=item modified
Returns true if any of this object's values have been modified with set (or via
=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
=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'}
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,
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'} ) {
=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
my( $type, $header, $sep_char,
$fixedlength_format, $xml_format, $asn_format,
- $parser_opt, $row_callback, @fields );
+ $parser_opt, $row_callback, $hash_callback, @fields );
my $postinsert_callback = '';
$postinsert_callback = $param->{'postinsert_callback'}
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'} ) {
? $param->{'format_row_callbacks'}{ $param->{'format'} }
: '';
+ $hash_callback =
+ $param->{'format_hash_callbacks'}
+ ? $param->{'format_hash_callbacks'}{ $param->{'format'} }
+ : '';
+
@fields = @{ $formats->{ $format } };
} elsif ( $param->{'fields'} ) {
$sep_char = ',';
$fixedlength_format = '';
$row_callback = '';
+ $hash_callback = '';
@fields = @{ $param->{'fields'} };
} else {
$hash{custnum} = $2;
}
+ %hash = &{$hash_callback}(%hash) if $hash_callback;
+
#my $table = $param->{table};
my $class = "FS::$table";
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;
'';
}
+=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
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
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";
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;
}
$table = $something->table;
} else {
$table = $something;
- $something = "FS::$table";
+ #$something = "FS::$table";
}
return (real_fields($table));
}
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
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
}
+=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