From cad4eadf964cb65841d7cb6f0bcf804f1d39ae2c Mon Sep 17 00:00:00 2001 From: ivan Date: Mon, 12 Oct 1998 07:03:09 +0000 Subject: [PATCH 1/1] Initial revision --- README | 43 +++ bin/fs-setup | 542 ++++++++++++++++++++++++++++++++ site_perl/Conf.pm | 113 +++++++ site_perl/Invoice.pm | 45 +++ site_perl/Record.pm | 868 +++++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 1611 insertions(+) create mode 100644 README create mode 100755 bin/fs-setup create mode 100644 site_perl/Conf.pm create mode 100644 site_perl/Invoice.pm create mode 100644 site_perl/Record.pm diff --git a/README b/README new file mode 100644 index 000000000..14234df5a --- /dev/null +++ b/README @@ -0,0 +1,43 @@ +Freeside, (pre) 1.1.4 + +Copyright (C) 1998 Silicon Interactive Software Design. All rights reserved. + + This program is free software; you can redistribute it and/or modify + it under the terms of either: + + a) the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any + later version, or + + b) the "Artistic License" + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the + GNU General Public License or the Artistic License for more details. + + You should have received a copy of the GNU General Public + License along with this program, in the file `GPL'; if not, + write to the Free Software Foundation, Inc., 59 Temple Place - Suite + 330, Boston, MA 02111-1307, USA. + + You should have received a copy of the Artistic License along with + this program, in the file `Artistic'; if not, download it from + http://www.perl.com/CPAN/doc/misc/license/Artistic + +Freeside is a billing and administration package for Internet Service +Providers. + +The Freeside home page is at `http://www.sisd.com/freeside'. + +The documentation is in `htdocs/docs'. + +A mailing list for users and developers is available. Send a blank message to + to subscribe. + +Commercial support is available from Ivan Kohler . Please +subscribe to the the mailing list to request free support! + +Ivan Kohler +ivan@sisd.com + diff --git a/bin/fs-setup b/bin/fs-setup new file mode 100755 index 000000000..45332d85c --- /dev/null +++ b/bin/fs-setup @@ -0,0 +1,542 @@ +#!/usr/bin/perl -Tw +# +# create database and necessary tables, etc. DBI version. +# +# ivan@sisd.com 97-nov-8,9 +# +# agent_type and type_pkgs added. +# (index need to be declared, & primary keys shoudln't have mysql syntax) +# ivan@sisd.com 97-nov-13 +# +# pulled modified version back out of register.cgi ivan@sisd.com 98-feb-21 +# +# removed extraneous sample data ivan@sisd.com 98-mar-23 +# +# gained the big hash from dbdef.pm, dbdef.pm usage rewrite ivan@sisd.com +# 98-apr-19 - 98-may-11 plus +# +# finished up ivan@sisd.com 98-jun-1 +# +# part_svc fields are all forced NULL, not the opposite +# hmm: also are forced varchar($char_d) as fixed '0' for things like +# uid is Not Good. will this break anything else? +# ivan@sisd.com 98-jun-29 +# +# ss is 11 chars ivan@sisd.com 98-jul-20 +# +# setup of arbitrary radius fields ivan@sisd.com 98-aug-9 +# +# ouch, removed index on company name that wasn't supposed to be there +# ivan@sisd.com 98-sep-4 +# +# fix radius attributes ivan@sisd.com 98-sep-27 + +#to delay loading dbdef until we're ready +BEGIN { $FS::Record::setup_hack = 1; } + +use strict; +use DBI; +use FS::dbdef; +use FS::UID qw(adminsuidsetup datasrc); +use FS::Record; +use FS::cust_main_county; + +#needs to match FS::Record +my($dbdef_file) = "/var/spool/freeside/dbdef.". datasrc; + +### + +print "\nEnter the maximum username length: "; +my($username_len)=&getvalue; + +print "\n\n", <); + chop $x; + $x; +} + +### + +my($char_d) = 80; #default maxlength for text fields + +#my(@date_type) = ( 'timestamp', '', '' ); +my(@date_type) = ( 'int', 'NULL', '' ); +my(@perl_type) = ( 'long varchar', 'NULL', '' ); +my(@money_type); +if (datasrc =~ m/Pg/) { #Pg can't do decimal(10,2) + @money_type = ( 'money', '', '' ); +} else { + @money_type = ( 'decimal', '', '10,2' ); +} + +### +# create a dbdef object from the old data structure +### + +my(%tables)=&tables_hash_hack; + +#turn it into objects +my($dbdef) = new FS::dbdef ( map { + my(@columns); + while (@{$tables{$_}{'columns'}}) { + my($name,$type,$null,$length)=splice @{$tables{$_}{'columns'}}, 0, 4; + push @columns, new FS::dbdef_column ( $name,$type,$null,$length ); + } + FS::dbdef_table->new( + $_, + $tables{$_}{'primary_key'}, + #FS::dbdef_unique->new(@{$tables{$_}{'unique'}}), + #FS::dbdef_index->new(@{$tables{$_}{'index'}}), + FS::dbdef_unique->new($tables{$_}{'unique'}), + FS::dbdef_index->new($tables{$_}{'index'}), + @columns, + ); +} (keys %tables) ); + +#add radius attributes to svc_acct + +my($svc_acct)=$dbdef->table('svc_acct'); + +my($attribute); +foreach $attribute (@attributes) { + $svc_acct->addcolumn ( new FS::dbdef_column ( + 'radius_'. $attribute, + 'varchar', + 'NULL', + $char_d, + )); +} + +#make part_svc table (but now as object) + +my($part_svc)=$dbdef->table('part_svc'); + +#because of svc_acct_pop +#foreach (grep /^svc_/, $dbdef->tables) { +#foreach (qw(svc_acct svc_acct_sm svc_charge svc_domain svc_wo)) { +foreach (qw(svc_acct svc_acct_sm svc_domain)) { + my($table)=$dbdef->table($_); + my($col); + foreach $col ( $table->columns ) { + next if $col =~ /^svcnum$/; + $part_svc->addcolumn( new FS::dbdef_column ( + $table->name. '__' . $table->column($col)->name, + 'varchar', #$table->column($col)->type, + 'NULL', + $char_d, #$table->column($col)->length, + )); + $part_svc->addcolumn ( new FS::dbdef_column ( + $table->name. '__'. $table->column($col)->name . "_flag", + 'char', + 'NULL', + 1, + )); + } +} + +#important +$dbdef->save($dbdef_file); +FS::Record::reload_dbdef; + +### +# create 'em +### + +my($dbh)=adminsuidsetup; + +#create tables +$|=1; + +my($table); +foreach ($dbdef->tables) { + my($table)=$dbdef->table($_); + print "Creating $_..."; + + my($statement); + + #create table + foreach $statement ($table->sql_create_table(datasrc)) { + #print $statement, "\n"; + $dbh->do( $statement ) + or die "CREATE error: ",$dbh->errstr, "\ndoing statement: $statement"; + } + + print "\n"; +} + +#not really sample data (and shouldn't default to US) + +#cust_main_county +foreach ( qw( +AL AK AS AZ AR CA CO CT DC DE FM FL GA GU HI ID IL IN IA KS KY LA +ME MH MD MA MI MN MS MO MT NC ND NE NH NJ NM NV NY MP OH OK OR PA PW PR RI +SC SD TN TX TT UT VT VI VA WA WV WI WY AE AA AP +) ) { + my($cust_main_county)=create FS::cust_main_county({ + 'state' => $_, + 'tax' => 0, + }); + my($error); + $error=$cust_main_county->insert; + die $error if $error; +} + +$dbh->disconnect or die $dbh->errstr; + +### +# Now it becomes an object. much better. +### +sub tables_hash_hack { + + #note that s/(date|change)/_$1/; to avoid keyword conflict. + #put a kludge in FS::Record to catch this or? (pry need some date-handling + #stuff anyway also) + + my(%tables)=( #yech.} + + 'agent' => { + 'columns' => [ + 'agentnum', 'int', '', '', + 'agent', 'varchar', '', $char_d, + 'typenum', 'int', '', '', + 'freq', 'smallint', 'NULL', '', + 'prog', @perl_type, + ], + 'primary_key' => 'agentnum', + 'unique' => [ [] ], + 'index' => [ ['typenum'] ], + }, + + 'agent_type' => { + 'columns' => [ + 'typenum', 'int', '', '', + 'atype', 'varchar', '', $char_d, + ], + 'primary_key' => 'typenum', + 'unique' => [ [] ], + 'index' => [ [] ], + }, + + 'type_pkgs' => { + 'columns' => [ + 'typenum', 'int', '', '', + 'pkgpart', 'int', '', '', + ], + 'primary_key' => '', + 'unique' => [ ['typenum', 'pkgpart'] ], + 'index' => [ ['typenum'] ], + }, + + 'cust_bill' => { + 'columns' => [ + 'invnum', 'int', '', '', + 'custnum', 'int', '', '', + '_date', @date_type, + 'charged', @money_type, + 'owed', @money_type, + 'printed', 'int', '', '', + ], + 'primary_key' => 'invnum', + 'unique' => [ [] ], + 'index' => [ ['custnum'] ], + }, + + 'cust_bill_pkg' => { + 'columns' => [ + 'pkgnum', 'int', '', '', + 'invnum', 'int', '', '', + 'setup', @money_type, + 'recur', @money_type, + 'sdate', @date_type, + 'edate', @date_type, + ], + 'primary_key' => '', + 'unique' => [ ['pkgnum', 'invnum'] ], + 'index' => [ ['invnum'] ], + }, + + 'cust_credit' => { + 'columns' => [ + 'crednum', 'int', '', '', + 'custnum', 'int', '', '', + '_date', @date_type, + 'amount', @money_type, + 'credited', @money_type, + 'otaker', 'varchar', '', 8, + 'reason', 'varchar', '', 255, + ], + 'primary_key' => 'crednum', + 'unique' => [ [] ], + 'index' => [ ['custnum'] ], + }, + + 'cust_main' => { + 'columns' => [ + 'custnum', 'int', '', '', + 'agentnum', 'int', '', '', + 'last', 'varchar', '', $char_d, + 'first', 'varchar', '', $char_d, + 'ss', 'char', 'NULL', 11, + 'company', 'varchar', 'NULL', $char_d, + 'address1', 'varchar', '', $char_d, + 'address2', 'varchar', 'NULL', $char_d, + 'city', 'varchar', '', $char_d, + 'county', 'varchar', 'NULL', $char_d, + 'state', 'char', '', 2, + 'zip', 'varchar', '', 10, + 'country', 'char', '', 2, + 'daytime', 'varchar', 'NULL', 20, + 'night', 'varchar', 'NULL', 20, + 'fax', 'varchar', 'NULL', 12, + 'payby', 'char', '', 4, + 'payinfo', 'varchar', 'NULL', 16, + 'paydate', @date_type, + 'payname', 'varchar', 'NULL', $char_d, + 'tax', 'char', 'NULL', 1, + 'otaker', 'varchar', '', 8, + 'refnum', 'int', '', '', + ], + 'primary_key' => 'custnum', + 'unique' => [ [] ], + #'index' => [ ['last'], ['company'] ], + 'index' => [ ['last'], ], + }, + + 'cust_main_county' => { #county+state are checked off the cust_main_county + #table for validation and to provide a tax rate. + #add country? + 'columns' => [ + 'taxnum', 'int', '', '', + 'state', 'char', '', 2, #two letters max in US... elsewhere? + 'county', 'varchar', '', $char_d, + 'tax', 'real', '', '', #tax % + ], + 'primary_key' => 'taxnum', + 'unique' => [ [] ], + # 'unique' => [ ['taxnum'], ['state', 'county'] ], + 'index' => [ [] ], + }, + + 'cust_pay' => { + 'columns' => [ + 'paynum', 'int', '', '', + 'invnum', 'int', '', '', + 'paid', @money_type, + '_date', @date_type, + 'payby', 'char', '', 4, # CARD/BILL/COMP, should be index into + # payment type table. + 'payinfo', 'varchar', 'NULL', 16, #see cust_main above + 'paybatch', 'varchar', 'NULL', $char_d, #for auditing purposes. + ], + 'primary_key' => 'paynum', + 'unique' => [ [] ], + 'index' => [ ['invnum'] ], + }, + + 'cust_pay_batch' => { #what's this used for again? list of customers + #in current CARD batch? (necessarily CARD?) + 'columns' => [ + 'invnum', 'int', '', '', + 'custnum', 'int', '', '', + 'last', 'varchar', '', $char_d, + 'first', 'varchar', '', $char_d, + 'address1', 'varchar', '', $char_d, + 'address2', 'varchar', 'NULL', $char_d, + 'city', 'varchar', '', $char_d, + 'state', 'char', '', 2, + 'zip', 'varchar', '', 10, + 'country', 'char', '', 2, + 'trancode', 'TINYINT', '', '', + 'cardnum', 'varchar', '', 16, + 'exp', @date_type, + 'payname', 'varchar', 'NULL', $char_d, + 'amount', @money_type, + ], + 'primary_key' => '', + 'unique' => [ [] ], + 'index' => [ ['invnum'], ['custnum'] ], + }, + + 'cust_pkg' => { + 'columns' => [ + 'pkgnum', 'int', '', '', + 'custnum', 'int', '', '', + 'pkgpart', 'int', '', '', + 'otaker', 'varchar', '', 8, + 'setup', @date_type, + 'bill', @date_type, + 'susp', @date_type, + 'cancel', @date_type, + 'expire', @date_type, + ], + 'primary_key' => 'pkgnum', + 'unique' => [ [] ], + 'index' => [ ['custnum'] ], + }, + + 'cust_refund' => { + 'columns' => [ + 'refundnum', 'int', '', '', + 'crednum', 'int', '', '', + '_date', @date_type, + 'refund', @money_type, + 'otaker', 'varchar', '', 8, + 'reason', 'varchar', '', $char_d, + 'payby', 'char', '', 4, # CARD/BILL/COMP, should be index + # into payment type table. + 'payinfo', 'varchar', 'NULL', 16, #see cust_main above + ], + 'primary_key' => 'refundnum', + 'unique' => [ [] ], + 'index' => [ ['crednum'] ], + }, + + 'cust_svc' => { + 'columns' => [ + 'svcnum', 'int', '', '', + 'pkgnum', 'int', '', '', + 'svcpart', 'int', '', '', + ], + 'primary_key' => 'svcnum', + 'unique' => [ [] ], + 'index' => [ ['svcnum'], ['pkgnum'], ['svcpart'] ], + }, + + 'part_pkg' => { + 'columns' => [ + 'pkgpart', 'int', '', '', + 'pkg', 'varchar', '', $char_d, + 'comment', 'varchar', '', $char_d, + 'setup', @perl_type, + 'freq', 'smallint', '', '', #billing frequency (months) + 'recur', @perl_type, + ], + 'primary_key' => 'pkgpart', + 'unique' => [ [] ], + 'index' => [ [] ], + }, + + 'pkg_svc' => { + 'columns' => [ + 'pkgpart', 'int', '', '', + 'svcpart', 'int', '', '', + 'quantity', 'int', '', '', + ], + 'primary_key' => '', + 'unique' => [ ['pkgpart', 'svcpart'] ], + 'index' => [ ['pkgpart'] ], + }, + + 'part_referral' => { + 'columns' => [ + 'refnum', 'int', '', '', + 'referral', 'varchar', '', $char_d, + ], + 'primary_key' => 'refnum', + 'unique' => [ [] ], + 'index' => [ [] ], + }, + + 'part_svc' => { + 'columns' => [ + 'svcpart', 'int', '', '', + 'svc', 'varchar', '', $char_d, + 'svcdb', 'varchar', '', $char_d, + ], + 'primary_key' => 'svcpart', + 'unique' => [ [] ], + 'index' => [ [] ], + }, + + #(this should be renamed to part_pop) + 'svc_acct_pop' => { + 'columns' => [ + 'popnum', 'int', '', '', + 'city', 'varchar', '', $char_d, + 'state', 'char', '', 2, + 'ac', 'char', '', 3, + 'exch', 'char', '', 3, + #rest o' number? + ], + 'primary_key' => 'popnum', + 'unique' => [ [] ], + 'index' => [ [] ], + }, + + 'svc_acct' => { + 'columns' => [ + 'svcnum', 'int', '', '', + 'username', 'varchar', '', $username_len, #unique (& remove dup code) + '_password', 'varchar', '', 25, #13 for encryped pw's plus ' *SUSPENDED* + 'popnum', 'int', 'NULL', '', + 'uid', 'bigint', 'NULL', '', + 'gid', 'bigint', 'NULL', '', + 'finger', 'varchar', 'NULL', $char_d, + 'dir', 'varchar', 'NULL', $char_d, + 'shell', 'varchar', 'NULL', $char_d, + 'quota', 'varchar', 'NULL', $char_d, + 'slipip', 'varchar', 'NULL', 15, #four TINYINTs, bah. + ], + 'primary_key' => 'svcnum', + 'unique' => [ [] ], + 'index' => [ ['username'] ], + }, + + 'svc_acct_sm' => { + 'columns' => [ + 'svcnum', 'int', '', '', + 'domsvc', 'int', '', '', + 'domuid', 'bigint', '', '', + 'domuser', 'varchar', '', $char_d, + ], + 'primary_key' => 'svcnum', + 'unique' => [ [] ], + 'index' => [ ['domsvc'], ['domuid'] ], + }, + + #'svc_charge' => { + # 'columns' => [ + # 'svcnum', 'int', '', '', + # 'amount', @money_type, + # ], + # 'primary_key' => 'svcnum', + # 'unique' => [ [] ], + # 'index' => [ [] ], + #}, + + 'svc_domain' => { + 'columns' => [ + 'svcnum', 'int', '', '', + 'domain', 'varchar', '', $char_d, + ], + 'primary_key' => 'svcnum', + 'unique' => [ ['domain'] ], + 'index' => [ [] ], + }, + + #'svc_wo' => { + # 'columns' => [ + # 'svcnum', 'int', '', '', + # 'svcnum', 'int', '', '', + # 'svcnum', 'int', '', '', + # 'worker', 'varchar', '', $char_d, + # '_date', @date_type, + # ], + # 'primary_key' => 'svcnum', + # 'unique' => [ [] ], + # 'index' => [ [] ], + #}, + + ); + + %tables; + +} + diff --git a/site_perl/Conf.pm b/site_perl/Conf.pm new file mode 100644 index 000000000..d3ef307c0 --- /dev/null +++ b/site_perl/Conf.pm @@ -0,0 +1,113 @@ +package FS::Conf; + +use vars qw($default_dir); +use IO::File; + +$default_dir='/var/spool/freeside/conf'; + +=head1 NAME + +FS::Conf - Read access to Freeside configuration values + +=head1 SYNOPSIS + + use FS::Conf; + + $conf = new FS::Conf; + $conf = new FS::Conf "/non/standard/config/directory"; + + $dir = $conf->dir; + + $value = $conf->config('key'); + @list = $conf->config('key'); + $bool = $conf->exists('key'); + +=head1 DESCRIPTION + +Read access to Freeside configuration values. Keys currently map to filenames, +but this may change in the future. + +=head1 METHODS + +=over 4 + +=item new [ DIRECTORY ] + +Create a new configuration object. Optionally, a non-default directory may +be specified. + +=cut + +sub new { + my($proto,$dir) = @_; + my($class) = ref($proto) || $proto; + my($self) = { 'dir' => $dir || $default_dir } ; + bless ($self, $class); +} + +=item dir + +Returns the directory. + +=cut + +sub dir { + my($self) = @_; + $self->{dir}; +} + +=item config + +Returns the configuration value or values (depending on context) for key. + +=cut + +sub config { + my($self,$file)=@_; + my($dir)=$self->dir; + my $fh = new IO::File "<$dir/$file" or return; + if ( wantarray ) { + map { + /^(.*)$/ or die "Illegal line in $dir/$file:\n$_\n"; + $1; + } <$fh>; + } else { + <$fh> =~ /^(.*)$/ or die "Illegal line in $dir/$file:\n$_\n"; + $1; + } +} + +=item exists + +Returns true if the specified key exists, even if the corresponding value +is undefined. + +=cut + +sub exists { + my($self,$file)=@_; + my($dir) = $self->dir; + -e "$dir/$file"; +} + +=back + +=head1 BUGS + +The option to specify a non-default directory should probably be removed. + +Write access (with locking) should be implemented. + +=head1 SEE ALSO + +config.html from the base documentation contains a list of configuration files. + +=head1 HISTORY + +Ivan Kohler 98-sep-6 + +sub exists forgot to fetch $dir ivan@sisd.com 98-sep-27 + +=cut + +1; diff --git a/site_perl/Invoice.pm b/site_perl/Invoice.pm new file mode 100644 index 000000000..5eb596fad --- /dev/null +++ b/site_perl/Invoice.pm @@ -0,0 +1,45 @@ +package FS::Invoice; + +use strict; +use vars qw(@ISA); +use FS::cust_bill; + +@ISA = qw(FS::cust_bill); + +#warn "FS::Invoice depriciated\n"; + +=head1 NAME + +FS::Invoice - Legacy stub + +=head1 SYNOPSIS + +The functioanlity of FS::invoice has been integrated in FS::cust_bill. + +=head1 HISTORY + +ivan@voicenet.com 97-jun-25 - 27 + +maybe should be changed to be OO-functions on $cust_bill objects? +(instead of passing invnum, ugh). + +ISA cust_bill and return inovice instead of passing filehandle +ivan@sisd.com 98-mar-13 + +(add postscript output!) + +close our kid when we're done ivan@sisd.com 98-jun-4 + +separated code which shuffled data from code which formatted. +(so i could) fixed past due notices showing up when balance due =< 0 +return address comes from /var/spool/freeside/conf/address +ivan@sisd.com 98-jul-2 + +pod ivan@sisd.com 98-sep-20something + +s/ISA/@ISA/ in use vars ivan@sisd.com 98-sep-27 + +=cut + +1; + diff --git a/site_perl/Record.pm b/site_perl/Record.pm new file mode 100644 index 000000000..9b308508a --- /dev/null +++ b/site_perl/Record.pm @@ -0,0 +1,868 @@ +package FS::Record; + +use strict; +use vars qw($dbdef_file $dbdef $setup_hack $AUTOLOAD @ISA @EXPORT_OK); +use subs qw(reload_dbdef); +use Exporter; +use Carp; +use File::CounterFile; +use FS::UID qw(dbh checkruid swapuid getotaker datasrc); +use FS::dbdef; + +@ISA = qw(Exporter); +@EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef); + +$File::CounterFile::DEFAULT_DIR = "/var/spool/freeside/counters" ; + +$dbdef_file = "/var/spool/freeside/dbdef.". datasrc; + +reload_dbdef unless $setup_hack; + +=head1 NAME + +FS::Record - Database record objects + +=head1 SYNOPSIS + + use FS::Record; + use FS::Record qw(dbh fields hfields qsearch qsearchs dbdef); + + $record = new FS::Record 'table', \%hash; + $record = new FS::Record 'table', { 'column' => 'value', ... }; + + $record = qsearchs FS::Record 'table', \%hash; + $record = qsearchs FS::Record 'table', { 'column' => 'value', ... }; + @records = qsearch FS::Record 'table', \%hash; + @records = qsearch FS::Record 'table', { 'column' => 'value', ... }; + + $table = $record->table; + $dbdef_table = $record->dbdef_table; + + $value = $record->get('column'); + $value = $record->getfield('column'); + $value = $record->column; + + $record->set( 'column' => 'value' ); + $record->setfield( 'column' => 'value' ); + $record->column('value'); + + %hash = $record->hash; + + $hashref = $record->hashref; + + $error = $record->add; + + $error = $record->del; + + $error = $new_record->rep($old_record); + + $value = $record->unique('column'); + + $value = $record->ut_float('column'); + $value = $record->ut_number('column'); + $value = $record->ut_numbern('column'); + $value = $record->ut_money('column'); + $value = $record->ut_text('column'); + $value = $record->ut_textn('column'); + $value = $record->ut_alpha('column'); + $value = $record->ut_alphan('column'); + $value = $record->ut_phonen('column'); + $value = $record->ut_anythingn('column'); + + $dbdef = reload_dbdef; + $dbdef = reload_dbdef "/non/standard/filename"; + $dbdef = dbdef; + + $quoted_value = _quote($value,'table','field'); + + #depriciated + $fields = hfields('table'); + if ( $fields->{Field} ) { # etc. + + @fields = fields 'table'; + + +=head1 DESCRIPTION + +(Mostly) object-oriented interface to database records. Records are currently +implemented on top of DBI. FS::Record is intended as a base class for +table-specific classes to inherit from, i.e. FS::cust_main. + +=head1 METHODS + +=over 4 + +=item new TABLE, HASHREF + +Creates a new record. It doesn't store it in the database, though. See +L<"add"> for that. + +Note that the object stores this hash reference, not a distinct copy of the +hash it points to. You can ask the object for a copy with the I +method. + +=cut + +sub new { + my($proto,$table,$hashref) = @_; + confess "Second arguement to FS::Record->new is not a HASH ref: ", + ref($hashref), " ", $hashref, "\n" + unless ref($hashref) eq 'HASH'; #bad practice? + + #check to make sure $table exists? (ask dbdef) + + foreach my $field ( FS::Record::fields $table ) { + $hashref->{$field}='' unless defined $hashref->{$field}; + } + + # mySQL must rtrim the inbound text strings or store them z-terminated + # I simulate this for Postgres below + # Turned off in favor of ChopBlanks in UID.pm (see man DBI) + #if (datasrc =~ m/Pg/) + #{ + # foreach my $index (keys %$hashref) + # { + # $$hashref{$index} = unpack("A255", $$hashref{$index}) + # if ($$hashref{$index} =~ m/ $/) ; + # } + #} + + foreach my $column (keys %{$hashref}) { + #trim the '$' from money fields for Pg (beong HERE?) + #(what about Pg i18n?) + if ( datasrc =~ m/Pg/ + && $dbdef->table($table)->column($column)->type eq 'money' ) { + ${$hashref}{$column} =~ s/^\$//; + } + #foreach my $column ( grep $dbdef->table($table)->column($_)->type eq 'money', keys %{$hashref} ) { + # ${$hashref}{$column} =~ s/^\$//; + #} + } + + my $class = ref($proto) || $proto; + my $self = { 'Table' => $table, + 'Hash' => $hashref, + }; + + bless ($self, $class); + +} + +=item qsearch TABLE, HASHREF + +Searches the database for all records matching (at least) the key/value pairs +in HASHREF. Returns all the records found as FS::Record objects. + +=cut + +# Usage: @records = &FS::Search::qsearch($table,\%hash); +# Each element of @records is a FS::Record object. +sub qsearch { + my($table,$record) = @_; + my($dbh) = dbh; + + my(@fields)=grep exists($record->{$_}), fields($table); + + my($sth); + my($statement) = "SELECT * FROM $table". ( @fields + ? " WHERE ". join(' AND ', + map("$_ = ". _quote($record->{$_},$table,$_), @fields) + ) + : '' + ); + $sth=$dbh->prepare($statement) + or croak $dbh->errstr; #is that a little too harsh? hmm. + + map { + new FS::Record ($table,$sth->fetchrow_hashref); + } ( 1 .. $sth->execute ); + +} + +=item qsearchs TABLE, HASHREF + +Searches the database for a record matching (at least) the key/value pairs +in HASHREF, and returns the record found as an FS::Record object. If more than +one record matches, it Bs but returns the first. If this happens, you +either made a logic error in asking for a single item, or your data is +corrupted. + +=cut + +sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash); + my(@result) = qsearch(@_); + carp "Multiple records in scalar search!" if scalar(@result) > 1; + #should warn more vehemently if the search was on a primary key? + $result[0]; +} + +=item table + +Returns the table name. + +=cut + +sub table { + my($self) = @_; + $self -> {'Table'}; +} + +=item dbdef_table + +Returns the FS::dbdef_table object for the table. + +=cut + +sub dbdef_table { + my($self)=@_; + my($table)=$self->table; + $dbdef->table($table); +} + +=item get, getfield COLUMN + +Returns the value of the column/field/key COLUMN. + +=cut + +sub get { + my($self,$field) = @_; + # to avoid "Use of unitialized value" errors + if ( defined ( $self->{Hash}->{$field} ) ) { + $self->{Hash}->{$field}; + } else { + ''; + } +} +sub getfield { + get(@_); +} + +=item set, setfield COLUMN, VALUE + +Sets the value of the column/field/key COLUMN to VALUE. Returns VALUE. + +=cut + +sub set { + my($self,$field,$value) = @_; + $self->{'Hash'}->{$field} = $value; +} +sub setfield { + set(@_); +} + +=item AUTLOADED METHODS + +$record->column is a synonym for $record->get('column'); + +$record->column('value') is a synonym for $record->set('column','value'); + +=cut + +sub AUTOLOAD { + my($self,$value)=@_; + my($field)=$AUTOLOAD; + $field =~ s/.*://; + if ( defined($value) ) { + $self->setfield($field,$value); + } else { + $self->getfield($field); + } +} + +=item hash + +Returns a list of the column/value pairs, usually for assigning to a new hash. + +To make a distinct duplicate of an FS::Record object, you can do: + + $new = new FS::Record ( $old->table, { $old->hash } ); + +=cut + +sub hash { + my($self) = @_; + %{ $self->{'Hash'} }; +} + +=item hashref + +Returns a reference to the column/value hash. + +=cut + +sub hashref { + my($self) = @_; + $self->{'Hash'}; +} + +=item add + +Adds this record to the database. If there is an error, returns the error, +otherwise returns false. + +=cut + +sub add { + my($self) = @_; + my($dbh)=dbh; + my($table)=$self->table; + + #single-field unique keys are given a value if false + #(like MySQL's AUTO_INCREMENT) + foreach ( $dbdef->table($table)->unique->singles ) { + $self->unique($_) unless $self->getfield($_); + } + #and also the primary key + my($primary_key)=$dbdef->table($table)->primary_key; + $self->unique($primary_key) + if $primary_key && ! $self->getfield($primary_key); + + my (@fields) = + grep defined($self->getfield($_)) && $self->getfield($_) ne "", + fields($table) + ; + + my($sth); + my($statement)="INSERT INTO $table ( ". + join(', ',@fields ). + ") VALUES (". + join(', ',map(_quote($self->getfield($_),$table,$_), @fields)). + ")" + ; + $sth = $dbh->prepare($statement) or return $dbh->errstr; + + local $SIG{HUP} = 'IGNORE'; + local $SIG{INT} = 'IGNORE'; + local $SIG{QUIT} = 'IGNORE'; + local $SIG{TERM} = 'IGNORE'; + local $SIG{TSTP} = 'IGNORE'; + + $sth->execute or return $sth->errstr; + + ''; +} + +=item del + +Delete this record from the database. If there is an error, returns the error, +otherwise returns false. + +=cut + +sub del { + my($self) = @_; + my($dbh)=dbh; + my($table)=$self->table; + + my($sth); + my($statement)="DELETE FROM $table WHERE ". join(' AND ', + map { + $self->getfield($_) eq '' + ? "$_ IS NULL" + : "$_ = ". _quote($self->getfield($_),$table,$_) + } ( $dbdef->table($table)->primary_key ) + ? ($dbdef->table($table)->primary_key) + : fields($table) + ); + $sth = $dbh->prepare($statement) or return $dbh->errstr; + + local $SIG{HUP} = 'IGNORE'; + local $SIG{INT} = 'IGNORE'; + local $SIG{QUIT} = 'IGNORE'; + local $SIG{TERM} = 'IGNORE'; + local $SIG{TSTP} = 'IGNORE'; + + my($rc); + $rc=$sth->execute or return $sth->errstr; + #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0"; + + undef $self; #no need to keep object! + + ''; +} + +=item rep OLD_RECORD + +Replace the OLD_RECORD with this one in the database. If there is an error, +returns the error, otherwise returns false. + +=cut + +sub rep { + my($new,$old)=@_; + my($dbh)=dbh; + my($table)=$old->table; + my(@fields)=fields($table); + my(@diff)=grep $new->getfield($_) ne $old->getfield($_), @fields; + + if ( scalar(@diff) == 0 ) { + carp "Records identical"; + return ''; + } + + return "Records not in same table!" unless $new->table eq $table; + + my($sth); + my($statement)="UPDATE $table SET ". join(', ', + map { + "$_ = ". _quote($new->getfield($_),$table,$_) + } @diff + ). ' WHERE '. + join(' AND ', + map { + $old->getfield($_) eq '' + ? "$_ IS NULL" + : "$_ = ". _quote($old->getfield($_),$table,$_) +# } @fields +# } ( primary_key($table) ? (primary_key($table)) : @fields ) + } ( $dbdef->table($table)->primary_key + ? ($dbdef->table($table)->primary_key) + : @fields + ) + ) + ; + #warn $statement; + $sth = $dbh->prepare($statement) or return $dbh->errstr; + + local $SIG{HUP} = 'IGNORE'; + local $SIG{INT} = 'IGNORE'; + local $SIG{QUIT} = 'IGNORE'; + local $SIG{TERM} = 'IGNORE'; + local $SIG{TSTP} = 'IGNORE'; + + my($rc); + $rc=$sth->execute or return $sth->errstr; + #not portable #return "Record not found (or records identical)." if $rc eq "0E0"; + + ''; + +} + +=item unique COLUMN + +Replaces COLUMN in record with a unique number. Called by the B method +on primary keys and single-field unique columns (see L). +Returns the new value. + +=cut + +sub unique { + my($self,$field) = @_; + my($table)=$self->table; + + croak("&FS::UID::checkruid failed") unless &checkruid; + + 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); + + &swapuid; + 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}); #just in case + &swapuid; + + $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) =~ /^(\d+\.\d+)$/ || + $self->getfield($field) =~ /^(\d+)$/ || + $self->getfield($field) =~ /^(\d+\.\d+e\d+)$/ || + $self->getfield($field) =~ /^(\d+e\d+)$/) + or return "Illegal or empty (float) $field!"; + $self->setfield($field,$1); + ''; +} + +=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) =~ /^(\d+)$/ + or return "Illegal or empty (numeric) $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*)$/ + or return "Illegal (numeric) $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)=@_; + $self->getfield($field) =~ /^(\-)? ?(\d*)(\.\d{2})?$/ + or return "Illegal (money) $field!"; + $self->setfield($field,"$1$2$3" || 0); + ''; +} + +=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)=@_; + $self->getfield($field) =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/]+)$/ + or return "Illegal or empty (text) $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)=@_; + $self->getfield($field) =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/]*)$/ + or return "Illegal (text) $field"; + $self->setfield($field,$1); + ''; +} + +=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->setfield($field,$1); + ''; +} + +=item ut_alpha 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->setfield($field,$1); + ''; +} + +=item ut_phonen COLUMN + +Check/untaint phone numbers. May be null. If there is an error, returns +the error, otherwise returns false. + +=cut + +sub ut_phonen { + my($self,$field)=@_; + my $phonen = $self->getfield($field); + if ( $phonen eq '' ) { + $self->setfield($field,''); + } else { + $phonen =~ s/\D//g; + $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/ + or return "Illegal (phone) $field!"; + $phonen = "$1-$2-$3"; + $phonen .= " x$4" if $4; + $self->setfield($field,$phonen); + } + ''; +} + +=item ut_anything COLUMN + +Untaints arbitrary data. Be careful. + +=cut + +sub ut_anything { + my($self,$field)=@_; + $self->getfield($field) =~ /^(.*)$/ or return "Illegal $field!"; + $self->setfield($field,$1); + ''; +} + + +=head1 SUBROUTINES + +=over 4 + +=item reload_dbdef([FILENAME]) + +Load a database definition (see L), optionally from a non-default +filename. This command is executed at startup unless +I<$FS::Record::setup_hack> is true. Returns a FS::dbdef object. + +=cut + +sub reload_dbdef { + my $file = shift || $dbdef_file; + $dbdef = load FS::dbdef ($file); +} + +=item dbdef + +Returns the current database definition. See L. + +=cut + +sub dbdef { $dbdef; } + +=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,$field)=@_; + my($dbh)=dbh; + if ( $value =~ /^\d+(\.\d+)?$/ && +# ! ( datatype($table,$field) =~ /^char/ ) + ! ( $dbdef->table($table)->column($field)->type =~ /(char|binary)$/i ) + ) { + $value; + } else { + $dbh->quote($value); + } +} + +=item hfields TABLE + +This is depriciated. Don't use it. + +It returns a hash-type list with the fields of this record's table set true. + +=cut + +sub hfields { + carp "hfields is depriciated"; + my($table)=@_; + my(%hash); + foreach (fields($table)) { + $hash{$_}=1; + } + \%hash; +} + +=item fields TABLE + +This returns a list of the columns in this record's table +(See L). + +=cut + +# Usage: @fields = fields($table); +sub fields { + my($table) = @_; + #my(@fields) = $dbdef->table($table)->columns; + croak "Usage: \@fields = fields(\$table)" unless $table; + my($table_obj) = $dbdef->table($table); + croak "Unknown table $table" unless $table_obj; + $table_obj->columns; +} + +#sub _dump { +# my($self)=@_; +# join("\n", map { +# "$_: ". $self->getfield($_). "|" +# } (fields($self->table)) ); +#} + +#sub DESTROY { +# my $self = shift; +# #use Carp qw(cluck); +# #cluck "DESTROYING $self"; +# warn "DESTROYING $self"; +#} + +#sub is_tainted { +# return ! eval { join('',@_), kill 0; 1; }; +# } + +=back + +=head1 BUGS + +This module should probably be renamed, since much of the functionality is +of general use. It is not completely unlike Adapter::DBI (see below). + +Exported qsearch and qsearchs should be depriciated in favor of method calls +(against an FS::Record object like the old search and searchs that qsearch +and qsearchs were on top of.) + +The whole fields / hfields mess should be removed. + +The various WHERE clauses should be subroutined. + +table string should be depriciated in favor of FS::dbdef_table. + +No doubt we could benefit from a Tied hash. Documenting how exists / defined +true maps to the database (and WHERE clauses) would also help. + +The ut_ methods should ask the dbdef for a default length. + +ut_sqltype (like ut_varchar) should all be defined + +A fallback check method should be provided with uses the dbdef. + +The ut_money method assumes money has two decimal digits. + +The Pg money kludge in the new method only strips `$'. + +The ut_phonen method assumes US-style phone numbers. + +The _quote function should probably use ut_float instead of a regex. + +All the subroutines probably should be methods, here or elsewhere. + +=head1 SEE ALSO + +L, L, L + +Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan. + +=head1 HISTORY + +ivan@voicenet.com 97-jun-2 - 9, 19, 25, 27, 30 + +DBI version +ivan@sisd.com 97-nov-8 - 12 + +cleaned up, added autoloaded $self->any_field calls, moved DBI login stuff +to FS::UID +ivan@sisd.com 97-nov-21-23 + +since AUTO_INCREMENT is MySQL specific, use my own unique number generator +(again) +ivan@sisd.com 97-dec-4 + +untaint $user in unique (web demo hack...bah) +make unique skip multiple-field unique's from dbdef +ivan@sisd.com 97-dec-11 + +merge with FS::Search, which after all was just alternate constructors for +FS::Record objects. Makes lots of things cleaner. :) +ivan@sisd.com 97-dec-13 + +use FS::dbdef::primary key in replace searches, hopefully for all practical +purposes the string/number problem in SQL statements should be gone? +(SQL bites) +ivan@sisd.com 98-jan-20 + +Put all SQL statments in $statment before we $sth=$dbh->prepare( them, +for debugging reasons (warn $statement) ivan@sisd.com 98-feb-19 + +(sigh)... use dbdef type (char, etc.) instead of a regex to decide +what to quote in _quote (more sillines...) SQL bites. +ivan@sisd.com 98-feb-20 + +more friendly error messages ivan@sisd.com 98-mar-13 + +Added import of datasrc from FS::UID to allow Pg6.3 to work +Added code to right-trim strings read from Pg6.3 databases +Modified 'add' to only insert fields that actually have data +Added ut_float to handle floating point numbers (for sales tax). +Pg6.3 does not have a "SHOW FIELDS" statement, so I faked it 8). + bmccane@maxbaud.net 98-apr-3 + +commented out Pg wrapper around `` Modified 'add' to only insert fields that +actually have data '' ivan@sisd.com 98-apr-16 + +dbdef usage changes ivan@sisd.com 98-jun-1 + +sub fields now asks dbdef, not database ivan@sisd.com 98-jun-2 + +added debugging method ->_dump ivan@sisd.com 98-jun-16 + +use FS::dbdef::primary key in delete searches as well as replace +searches (SQL still bites) ivan@sisd.com 98-jun-22 + +sub dbdef_table ivan@sisd.com 98-jun-28 + +removed Pg wrapper around `` Modified 'add' to only insert fields that +actually have data '' ivan@sisd.com 98-jul-14 + +sub fields croaks on errors ivan@sisd.com 98-jul-17 + +$rc eq '0E0' doesn't mean we couldn't delete for all rdbmss +ivan@sisd.com 98-jul-18 + +commented out code to right-trim strings read from Pg6.3 databases; +ChopBlanks is in UID.pm ivan@sisd.com 98-aug-16 + +added code (with Pg wrapper) to deal with Pg money fields +ivan@sisd.com 98-aug-18 + +added pod documentation ivan@sisd.com 98-sep-6 + +ut_phonen got ''; at the end ivan@sisd.com 98-sep-27 + +=cut + +1; + -- 2.11.0