+ if ( $param->{'format'} ) {
+
+ my $format = $param->{'format'};
+ my $formats = $param->{formats};
+ die "unknown format $format" unless exists $formats->{ $format };
+
+ $type = $param->{'format_types'}
+ ? $param->{'format_types'}{ $format }
+ : $param->{type} || 'csv';
+
+
+ $header = $param->{'format_headers'}
+ ? $param->{'format_headers'}{ $param->{'format'} }
+ : 0;
+
+ $sep_char = $param->{'format_sep_chars'}
+ ? $param->{'format_sep_chars'}{ $param->{'format'} }
+ : ',';
+
+ $fixedlength_format =
+ $param->{'format_fixedlength_formats'}
+ ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
+ : '';
+
+ $parser_opt =
+ $param->{'format_parser_opts'}
+ ? $param->{'format_parser_opts'}{ $param->{'format'} }
+ : {};
+
+ $xml_format =
+ $param->{'format_xml_formats'}
+ ? $param->{'format_xml_formats'}{ $param->{'format'} }
+ : '';
+
+ $asn_format =
+ $param->{'format_asn_formats'}
+ ? $param->{'format_asn_formats'}{ $param->{'format'} }
+ : '';
+
+ $row_callback =
+ $param->{'format_row_callbacks'}
+ ? $param->{'format_row_callbacks'}{ $param->{'format'} }
+ : '';
+
+ $hash_callback =
+ $param->{'format_hash_callbacks'}
+ ? $param->{'format_hash_callbacks'}{ $param->{'format'} }
+ : '';
+
+ @fields = @{ $formats->{ $format } };
+
+ } elsif ( $param->{'fields'} ) {
+
+ $type = ''; #infer from filename
+ $header = 0;
+ $sep_char = ',';
+ $fixedlength_format = '';
+ $row_callback = '';
+ $hash_callback = '';
+ @fields = @{ $param->{'fields'} };
+
+ } else {
+ die "neither format nor fields specified";
+ }
+
+ #my $file = $param->{file};
+
+ unless ( $type ) {
+ if ( $file =~ /\.(\w+)$/i ) {
+ $type = lc($1);
+ } else {
+ #or error out???
+ warn "can't parse file type from filename $file; defaulting to CSV";
+ $type = 'csv';
+ }
+ $type = 'csv'
+ if $param->{'default_csv'} && $type ne 'xls';
+ }
+
+
+ my $row = 0;
+ my $count;
+ my $parser;
+ my @buffer = ();
+ my $asn_header_buffer;
+ if ( $type eq 'csv' || $type eq 'fixedlength' ) {
+
+ if ( $type eq 'csv' ) {
+
+ $parser_opt->{'binary'} = 1;
+ $parser_opt->{'sep_char'} = $sep_char if $sep_char;
+ $parser = Text::CSV_XS->new($parser_opt);
+
+ } elsif ( $type eq 'fixedlength' ) {
+
+ eval "use Parse::FixedLength;";
+ die $@ if $@;
+ $parser = Parse::FixedLength->new($fixedlength_format, $parser_opt);
+
+ } else {
+ die "Unknown file type $type\n";
+ }
+
+ @buffer = split(/\r?\n/, slurp($file) );
+ splice(@buffer, 0, ($header || 0) );
+ $count = scalar(@buffer);
+
+ } elsif ( $type eq 'xls' ) {
+
+ eval "use Spreadsheet::ParseExcel;";
+ die $@ if $@;
+
+ eval "use DateTime::Format::Excel;";
+ #for now, just let the error be thrown if it is used, since only CDR
+ # formats bill_west and troop use it, not other excel-parsing things
+ #die $@ if $@;
+
+ my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
+
+ $parser = $excel->{Worksheet}[0]; #first sheet
+
+ $count = $parser->{MaxRow} || $parser->{MinRow};
+ $count++;
+
+ $row = $header || 0;
+
+ } elsif ( $type eq 'xml' ) {
+
+ # FS::pay_batch
+ eval "use XML::Simple;";
+ die $@ if $@;
+ my $xmlrow = $xml_format->{'xmlrow'};
+ $parser = $xml_format->{'xmlkeys'};
+ die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
+ my $data = XML::Simple::XMLin(
+ $file,
+ 'SuppressEmpty' => '', #sets empty values to ''
+ 'KeepRoot' => 1,
+ );
+ my $rows = $data;
+ $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 return "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";
+ }
+
+ #my $columns;
+
+ local $SIG{HUP} = 'IGNORE';
+ local $SIG{INT} = 'IGNORE';
+ local $SIG{QUIT} = 'IGNORE';
+ local $SIG{TERM} = 'IGNORE';
+ local $SIG{TSTP} = 'IGNORE';
+ local $SIG{PIPE} = 'IGNORE';
+
+ my $oldAutoCommit = $FS::UID::AutoCommit;
+ local $FS::UID::AutoCommit = 0;
+ my $dbh = dbh;
+
+ #my $params = $param->{params} || {};
+ if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) {
+ my $batch_col = $param->{'batch_keycol'};
+
+ my $batch_class = 'FS::'. $param->{'batch_table'};
+ my $batch = $batch_class->new({
+ $param->{'batch_namecol'} => $param->{'batch_namevalue'}
+ });
+ my $error = $batch->insert;
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "can't insert batch record: $error";
+ }
+ #primary key via dbdef? (so the column names don't have to match)
+ my $batch_value = $batch->get( $param->{'batch_keycol'} );
+
+ $params->{ $batch_col } = $batch_value;
+ }
+
+ #my $job = $param->{job};
+ my $line;
+ my $imported = 0;
+ my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
+ while (1) {
+
+ my @columns = ();
+ my %hash = %$params;
+ if ( $type eq 'csv' ) {
+
+ last unless scalar(@buffer);
+ $line = shift(@buffer);
+
+ 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() . " " . $parser->error_diag;
+ };
+ @columns = $parser->fields();
+
+ } elsif ( $type eq 'fixedlength' ) {
+
+ last unless scalar(@buffer);
+ $line = shift(@buffer);
+
+ @columns = $parser->parse($line);
+
+ } elsif ( $type eq 'xls' ) {
+
+ last if $row > ($parser->{MaxRow} || $parser->{MinRow})
+ || ! $parser->{Cells}[$row];
+
+ my @row = @{ $parser->{Cells}[$row] };
+ @columns = map $_->{Val}, @row;
+
+ #my $z = 'A';
+ #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 = ();
+
+ foreach my $field ( @fields ) {
+
+ my $value = shift @columns;
+
+ if ( ref($field) eq 'CODE' ) {
+ #&{$field}(\%hash, $value);
+ push @later, $field, $value;
+ } else {
+ #??? $hash{$field} = $value if length($value);
+ $hash{$field} = $value if defined($value) && length($value);
+ }
+
+ }
+
+ if ( $custnum_prefix && $hash{custnum} =~ /^$custnum_prefix(0*([1-9]\d*))$/
+ && length($1) == $custnum_length ) {
+ $hash{custnum} = $2;
+ }
+
+ %hash = &{$hash_callback}(%hash) if $hash_callback;
+
+ #my $table = $param->{table};
+ my $class = "FS::$table";
+
+ my $record = $class->new( \%hash );
+
+ my $param = {};
+ while ( scalar(@later) ) {
+ my $sub = shift @later;
+ my $data = shift @later;
+ eval {
+ &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
+ };
+ if ( $@ ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
+ }
+ last if exists( $param->{skiprow} );
+ }
+ next if exists( $param->{skiprow} );
+
+ if ( $preinsert_callback ) {
+ my $error = &{$preinsert_callback}($record, $param);
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "preinsert_callback error". ( $line ? " for $line" : '' ).
+ ": $error";
+ }
+ next if exists $param->{skiprow} && $param->{skiprow};
+ }
+
+ 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;
+ return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
+ }
+
+ $row++;
+ $imported++;
+
+ if ( $postinsert_callback ) {
+ my $error = &{$postinsert_callback}($record, $param);
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "postinsert_callback error". ( $line ? " for $line" : '' ).
+ ": $error";
+ }
+ }
+
+ if ( $job && time - $min_sec > $last ) { #progress bar
+ $job->update_statustext( int(100 * $imported / $count) );
+ $last = time;
+ }
+
+ }
+
+ unless ( $imported || $param->{empty_ok} ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "Empty file!";
+ }
+
+ $dbh->commit or die $dbh->errstr if $oldAutoCommit;
+
+ ''; #no error
+
+}
+
+sub _h_statement {
+ my( $self, $action, $time ) = @_;
+
+ $time ||= time;
+
+ my %nohistory = map { $_=>1 } $self->nohistory_fields;
+
+ my @fields =
+ grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
+ real_fields($self->table);
+ ;
+
+ # If we're encrypting then don't store the payinfo in the history
+ if ( $conf_encryption && $self->table ne 'banned_pay' ) {
+ @fields = grep { $_ ne 'payinfo' } @fields;
+ }
+
+ my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
+
+ "INSERT INTO h_". $self->table. " ( ".
+ join(', ', qw(history_date history_user history_action), @fields ).
+ ") VALUES (".
+ join(', ', $time,
+ dbh->quote($FS::CurrentUser::CurrentUser->username),
+ dbh->quote($action),
+ @values
+ ).
+ ")"
+ ;
+}
+
+=item unique COLUMN
+
+B<Warning>: External use is B<deprecated>.
+
+Replaces COLUMN in record with a unique number, using counters in the
+filesystem. Used by the B<insert> method on single-field unique columns
+(see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
+that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
+
+Returns the new value.
+
+=cut
+
+sub unique {
+ my($self,$field) = @_;
+ my($table)=$self->table;
+
+ croak "Unique called on field $field, but it is ",
+ $self->getfield($field),
+ ", not null!"
+ if $self->getfield($field);
+
+ #warn "table $table is tainted" if is_tainted($table);
+ #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 } );
+
+ $index =~ /^(\d*)$/;
+ $index=$1;
+
+ $self->setfield($field,$index);
+
+}
+
+=item ut_float COLUMN
+
+Check/untaint 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_float {
+ my($self,$field)=@_ ;
+ ($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
+
+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
+
+#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_sfloat COLUMN
+
+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_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
+
+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) =~ /^\s*(\d*)\s*$/
+ or return "Illegal (numeric) $field: ". $self->getfield($field);
+ $self->setfield($field,$1);
+ '';
+}
+
+=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
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub ut_money {
+ my($self,$field)=@_;
+
+ 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);
+ }
+
+ '';
+}
+
+=item ut_moneyn COLUMN
+
+Check/untaint monetary numbers. May be negative. If there
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub ut_moneyn {
+ my($self,$field)=@_;
+ if ($self->getfield($field) eq '') {
+ $self->setfield($field, '');
+ return '';
+ }
+ $self->ut_money($field);
+}
+
+=item ut_text COLUMN
+
+Check/untaint text. Alphanumerics, spaces, and the following punctuation
+symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < > ~
+May not be null. If there is an error, returns the error, otherwise returns
+false.
+
+=cut
+
+sub ut_text {
+ my($self,$field)=@_;
+ #warn "msgcat ". \&msgcat. "\n";
+ #warn "notexist ". \¬exist. "\n";
+ #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
+ # \p{Word} = alphanumerics, marks (diacritics), and connectors
+ # see perldoc perluniprops
+ $self->getfield($field)
+ =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>\~$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: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
+May be null. If there is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub ut_textn {
+ my($self,$field)=@_;
+ return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
+ $self->ut_text($field);
+}
+
+=item ut_alpha COLUMN
+
+Check/untaint alphanumeric strings (no spaces). May not be null. If there is
+an error, returns the error, otherwise returns false.
+
+=cut
+
+sub ut_alpha {
+ my($self,$field)=@_;
+ $self->getfield($field) =~ /^(\w+)$/
+ or return "Illegal or empty (alphanumeric) $field: ".
+ $self->getfield($field);
+ $self->setfield($field,$1);
+ '';
+}
+
+=item ut_alphan COLUMN
+
+Check/untaint alphanumeric strings (no spaces). May be null. If there is an
+error, returns the error, otherwise returns false.
+
+=cut
+
+sub ut_alphan {
+ my($self,$field)=@_;
+ $self->getfield($field) =~ /^(\w*)$/
+ or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
+ $self->setfield($field,$1);
+ '';
+}
+
+=item ut_alphasn COLUMN
+
+Check/untaint alphanumeric strings, spaces allowed. May be null. If there is
+an error, returns the error, otherwise returns false.
+
+=cut
+
+sub ut_alphasn {
+ my($self,$field)=@_;
+ $self->getfield($field) =~ /^([\w ]*)$/
+ or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
+ $self->setfield($field,$1);
+ '';
+}
+
+
+=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
+the error, otherwise returns false.
+
+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_phonen {
+ my( $self, $field, $country ) = @_;
+ return $self->ut_alphan($field) unless defined $country;
+ my $phonen = $self->getfield($field);
+ if ( $phonen eq '' ) {
+ $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";
+ $phonen .= " x$4" if $4;
+ $self->setfield($field,$phonen);
+ } else {
+ warn "warning: don't know how to check phone numbers for country $country";
+ return $self->ut_textn($field);
+ }
+ '';
+}
+
+=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_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
+to 127.0.0.1.
+
+=cut
+
+sub ut_ip {
+ my( $self, $field ) = @_;
+ $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
+ $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
+ or return "Illegal (IP address) $field: ". $self->getfield($field);
+ for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
+ $self->setfield($field, "$1.$2.$3.$4");
+ '';
+}
+
+=item ut_ipn COLUMN
+
+Check/untaint ip addresses. IPv4 only for now, though ::1 is auto-translated
+to 127.0.0.1. May be null.
+
+=cut
+
+sub ut_ipn {
+ my( $self, $field ) = @_;
+ if ( $self->getfield($field) =~ /^()$/ ) {
+ $self->setfield($field,'');
+ '';
+ } else {
+ $self->ut_ip($field);
+ }
+}
+
+=item ut_ip46 COLUMN
+
+Check/untaint IPv4 or IPv6 address.
+
+=cut
+
+sub ut_ip46 {
+ my( $self, $field ) = @_;
+ my $ip = NetAddr::IP->new($self->getfield($field))
+ or return "Illegal (IP address) $field: ".$self->getfield($field);
+ $self->setfield($field, lc($ip->addr));
+ return '';
+}
+
+=item ut_ip46n
+
+Check/untaint IPv6 or IPv6 address. May be null.
+
+=cut
+
+sub ut_ip46n {
+ my( $self, $field ) = @_;
+ if ( $self->getfield($field) =~ /^$/ ) {
+ $self->setfield($field, '');
+ return '';
+ }
+ $self->ut_ip46($field);
+}
+
+=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, $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/^(-)//;
+
+ # ignore degree symbol at the end,
+ # but not otherwise supporting degree/minutes/seconds symbols
+ $coord =~ s/\N{DEGREE SIGN}\s*$//;
+
+ my ($d, $m, $s) = (0, 0, 0);
+
+ if (
+ (($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) =~ /^\s*$/) {
+ return '';
+ } else {
+ return $self->ut_coord($field, @_);
+ }
+
+}
+
+=item ut_domain COLUMN
+
+Check/untaint host and domain names. May not be null.
+
+=cut
projects / freeside.git / blobdiff