From c4534c2eb63a4eadfb588cefef0007e85c057036 Mon Sep 17 00:00:00 2001 From: ivan Date: Wed, 4 Aug 1999 07:38:13 +0000 Subject: [PATCH] move to FS directory: proper Perl module installation has arrived! --- site_perl/Bill.pm | 44 -- site_perl/CGI.pm | 264 ---------- site_perl/Conf.pm | 129 ----- site_perl/Invoice.pm | 45 -- site_perl/Record.pm | 1002 ------------------------------------ site_perl/SSH.pm | 157 ------ site_perl/UID.pm | 326 ------------ site_perl/agent.pm | 168 ------ site_perl/agent_type.pm | 192 ------- site_perl/cust_bill.pm | 482 ------------------ site_perl/cust_bill_pkg.pm | 150 ------ site_perl/cust_credit.pm | 191 ------- site_perl/cust_main.pm | 1070 --------------------------------------- site_perl/cust_main_county.pm | 132 ----- site_perl/cust_main_invoice.pm | 214 -------- site_perl/cust_pay.pm | 207 -------- site_perl/cust_pay_batch.pm | 235 --------- site_perl/cust_pkg.pm | 558 -------------------- site_perl/cust_refund.pm | 204 -------- site_perl/cust_svc.pm | 189 ------- site_perl/dbdef.pm | 174 ------- site_perl/dbdef_colgroup.pm | 108 ---- site_perl/dbdef_column.pm | 192 ------- site_perl/dbdef_index.pm | 43 -- site_perl/dbdef_table.pm | 258 ---------- site_perl/dbdef_unique.pm | 44 -- site_perl/part_pkg.pm | 204 -------- site_perl/part_referral.pm | 123 ----- site_perl/part_svc.pm | 182 ------- site_perl/pkg_svc.pm | 173 ------- site_perl/svc_Common.pm | 217 -------- site_perl/svc_acct.pm | 514 ------------------- site_perl/svc_acct_pop.pm | 124 ----- site_perl/svc_acct_sm.pm | 266 ---------- site_perl/svc_domain.pm | 458 ----------------- site_perl/table_template-svc.pm | 177 ------- site_perl/table_template.pm | 134 ----- site_perl/type_pkgs.pm | 128 ----- 38 files changed, 9478 deletions(-) delete mode 100644 site_perl/Bill.pm delete mode 100644 site_perl/CGI.pm delete mode 100644 site_perl/Conf.pm delete mode 100644 site_perl/Invoice.pm delete mode 100644 site_perl/Record.pm delete mode 100644 site_perl/SSH.pm delete mode 100644 site_perl/UID.pm delete mode 100644 site_perl/agent.pm delete mode 100644 site_perl/agent_type.pm delete mode 100644 site_perl/cust_bill.pm delete mode 100644 site_perl/cust_bill_pkg.pm delete mode 100644 site_perl/cust_credit.pm delete mode 100644 site_perl/cust_main.pm delete mode 100644 site_perl/cust_main_county.pm delete mode 100644 site_perl/cust_main_invoice.pm delete mode 100644 site_perl/cust_pay.pm delete mode 100644 site_perl/cust_pay_batch.pm delete mode 100644 site_perl/cust_pkg.pm delete mode 100644 site_perl/cust_refund.pm delete mode 100644 site_perl/cust_svc.pm delete mode 100644 site_perl/dbdef.pm delete mode 100644 site_perl/dbdef_colgroup.pm delete mode 100644 site_perl/dbdef_column.pm delete mode 100644 site_perl/dbdef_index.pm delete mode 100644 site_perl/dbdef_table.pm delete mode 100644 site_perl/dbdef_unique.pm delete mode 100644 site_perl/part_pkg.pm delete mode 100644 site_perl/part_referral.pm delete mode 100644 site_perl/part_svc.pm delete mode 100644 site_perl/pkg_svc.pm delete mode 100644 site_perl/svc_Common.pm delete mode 100644 site_perl/svc_acct.pm delete mode 100644 site_perl/svc_acct_pop.pm delete mode 100644 site_perl/svc_acct_sm.pm delete mode 100644 site_perl/svc_domain.pm delete mode 100644 site_perl/table_template-svc.pm delete mode 100644 site_perl/table_template.pm delete mode 100644 site_perl/type_pkgs.pm diff --git a/site_perl/Bill.pm b/site_perl/Bill.pm deleted file mode 100644 index 4d7e059ed..000000000 --- a/site_perl/Bill.pm +++ /dev/null @@ -1,44 +0,0 @@ -package FS::Bill; - -use strict; -use vars qw(@ISA); -use FS::cust_main; - -@ISA = qw(FS::cust_main); - -warn "FS::Bill depriciated\n"; - -=head1 NAME - -FS::Bill - Legacy stub - -=head1 SYNOPSIS - -The functionality of FS::Bill has been integrated into FS::cust_main. - -=head1 HISTORY - -ivan@voicenet.com 97-jul-24 - 25 - 28 - -use Safe; evaluate all fees with perl (still on TODO list until I write -some examples & test opmask to see if we can read db) -%hash=$obj->hash later ivan@sisd.com 98-mar-13 - -packages with no next bill date start at $time not time, this should -eliminate the last of the problems with billing at a past date -also rewrite the invoice priting logic not to print invoices for things -that haven't happended yet and update $cust_bill->printed when we print -so PAST DUE notices work, and s/date/_date/ -ivan@sisd.com 98-jun-4 - -more logic for past due stuff - packages with no next bill date start -at $cust_pkg->setup || $time ivan@sisd.com 98-jul-13 - -moved a few things in collection logic; negative charges should work -ivan@sisd.com 98-aug-6 - -pod, moved everything to FS::cust_main ivan@sisd.com 98-sep-19 - -=cut - -1; diff --git a/site_perl/CGI.pm b/site_perl/CGI.pm deleted file mode 100644 index 3ce53de9b..000000000 --- a/site_perl/CGI.pm +++ /dev/null @@ -1,264 +0,0 @@ -package FS::CGI; - -use strict; -use vars qw(@EXPORT_OK @ISA); -use Exporter; -use CGI; -use URI::URL; -use CGI::Carp qw(fatalsToBrowser); -use FS::UID; - -@ISA = qw(Exporter); -@EXPORT_OK = qw(header menubar idiot eidiot popurl table itable ntable); - -=head1 NAME - -FS::CGI - Subroutines for the web interface - -=head1 SYNOPSIS - - use FS::CGI qw(header menubar idiot eidiot popurl); - - print header( 'Title', '' ); - print header( 'Title', menubar('item', 'URL', ... ) ); - - idiot "error message"; - eidiot "error message"; - - $url = popurl; #returns current url - $url = popurl(3); #three levels up - -=head1 DESCRIPTION - -Provides a few common subroutines for the web interface. - -=head1 SUBROUTINES - -=over 4 - -=item header TITLE, MENUBAR - -Returns an HTML header. - -=cut - -sub header { - my($title,$menubar)=@_; - - my $x = < - - - $title - - - - - $title - -

-END - $x .= $menubar. "

" if $menubar; - $x; -} - -=item menubar ITEM, URL, ... - -Returns an HTML menubar. - -=cut - -sub menubar { #$menubar=menubar('Main Menu', '../', 'Item', 'url', ... ); - my($item,$url,@html); - while (@_) { - ($item,$url)=splice(@_,0,2); - push @html, qq!$item!; - } - join(' | ',@html); -} - -=item idiot ERROR - -This is depriciated. Don't use it. - -Sends headers and an HTML error message. - -=cut - -sub idiot { - #warn "idiot depriciated"; - my($error)=@_; - my $cgi = &FS::UID::cgi(); - if ( $cgi->isa('CGI::Base') ) { - no strict 'subs'; - &CGI::Base::SendHeaders; - } else { - print $cgi->header( '-expires' => 'now' ); - } - print < - - Error processing your request - - -
-

Error processing your request

-
- Your request could not be processed because of the following error: -

$error - - -END - -} - -=item eidiot ERROR - -This is depriciated. Don't use it. - -Sends headers and an HTML error message, then exits. - -=cut - -sub eidiot { - #warn "eidiot depriciated"; - idiot(@_); - exit; -} - -=item popurl LEVEL - -Returns current URL with LEVEL levels of path removed from the end (default 0). - -=cut - -sub popurl { - my($up)=@_; - my($cgi)=&FS::UID::cgi; - my($url)=new URI::URL $cgi->url; - my(@path)=$url->path_components; - splice @path, 0-$up; - $url->path_components(@path); - my $x = $url->as_string; - $x .= '/' unless $x =~ /\/$/; - $x; -} - -=item table - -Returns HTML tag for beginning a table. - -=cut - -sub table { - my $col = shift; - if ( $col ) { - qq!!; - } else { - "
"; - } -} - -=item itable - -Returns HTML tag for beginning an (invisible) table. - -=cut - -sub itable { - my $col = shift; - my $cellspacing = shift || 0; - if ( $col ) { - qq!
!; - } else { - qq!
!; - } -} - -=item ntable - -This is getting silly. - -=cut - -sub ntable { - my $col = shift; - my $cellspacing = shift || 0; - if ( $col ) { - qq!
!; - } else { - "
"; - } - -} - -=back - -=head1 BUGS - -Not OO. - -Not complete. - -=head1 SEE ALSO - -L, L - -=head1 HISTORY - -subroutines for the HTML/CGI GUI, not properly OO. :( - -ivan@sisd.com 98-apr-16 -ivan@sisd.com 98-jun-22 - -lose the background, eidiot ivan@sisd.com 98-sep-2 - -pod ivan@sisd.com 98-sep-12 - -$Log: CGI.pm,v $ -Revision 1.18 1999-04-15 15:22:12 ivan -make &idiot() work, yuck. - -Revision 1.17 1999/02/07 09:59:43 ivan -more mod_perl fixes, and bugfixes Peter Wemm sent via email - -Revision 1.16 1999/01/25 12:26:05 ivan -yet more mod_perl stuff - -Revision 1.15 1999/01/18 09:41:48 ivan -all $cgi->header calls now include ( '-expires' => 'now' ) for mod_perl -(good idea anyway) - -Revision 1.14 1999/01/18 09:22:37 ivan -changes to track email addresses for email invoicing - -Revision 1.12 1998/12/23 02:23:16 ivan -popurl always has trailing slash - -Revision 1.11 1998/11/12 07:43:54 ivan -*** empty log message *** - -Revision 1.10 1998/11/12 01:53:47 ivan -added table command - -Revision 1.9 1998/11/09 08:51:49 ivan -bug squash - -Revision 1.7 1998/11/09 06:10:59 ivan -added sub url - -Revision 1.6 1998/11/09 05:44:20 ivan -*** empty log message *** - -Revision 1.4 1998/11/09 04:55:42 ivan -support depriciated CGI::Base as well as CGI.pm (for now) - -Revision 1.3 1998/11/08 10:50:19 ivan -s/CGI::Base/CGI/; etc. - - -=cut - -1; - - diff --git a/site_perl/Conf.pm b/site_perl/Conf.pm deleted file mode 100644 index 0b2d5b328..000000000 --- a/site_perl/Conf.pm +++ /dev/null @@ -1,129 +0,0 @@ -package FS::Conf; - -use vars qw($default_dir); -use IO::File; - -=head1 NAME - -FS::Conf - Read access to Freeside configuration values - -=head1 SYNOPSIS - - use FS::Conf; - - $conf = new FS::Conf "/config/directory"; - - $FS::Conf::default_dir = "/config/directory"; - $conf = new FS::Conf; - - $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. A directory arguement is required if -$FS::Conf::default_dir has not been set. - -=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) = @_; - my $dir = $self->{dir}; - -e $dir or die "FATAL: $dir doesn't exist!"; - -d $dir or die "FATAL: $dir isn't a directory!"; - -r $dir or die "FATAL: Can't read $dir!"; - -x $dir or die "FATAL: $dir not searchable (executable)!"; - $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 (array context) in $dir/$file:\n$_\n"; - $1; - } <$fh>; - } else { - <$fh> =~ /^(.*)$/ - or die "Illegal line (scalar context) 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 - -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 - -$Log: Conf.pm,v $ -Revision 1.4 1999-05-11 10:09:13 ivan -try to diagnose strange multiple-line problem - -Revision 1.3 1999/03/29 01:29:33 ivan -die unless the configuration directory exists - -Revision 1.2 1998/11/13 04:08:44 ivan -no default default_dir (ironic) - - -=cut - -1; diff --git a/site_perl/Invoice.pm b/site_perl/Invoice.pm deleted file mode 100644 index 7fdcaaf6f..000000000 --- a/site_perl/Invoice.pm +++ /dev/null @@ -1,45 +0,0 @@ -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 functionality 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 deleted file mode 100644 index 5d69619ef..000000000 --- a/site_perl/Record.pm +++ /dev/null @@ -1,1002 +0,0 @@ -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 qw(carp cluck croak confess); -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); - -#ask FS::UID to run this stuff for us later -$FS::UID::callback{'FS::Record'} = sub { - $File::CounterFile::DEFAULT_DIR = "/usr/local/etc/freeside/counters.". datasrc; - $dbdef_file = "/usr/local/etc/freeside/dbdef.". datasrc; - &reload_dbdef unless $setup_hack; #$setup_hack needed now? -}; - -=head1 NAME - -FS::Record - Database record objects - -=head1 SYNOPSIS - - use FS::Record; - use FS::Record qw(dbh fields 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->insert; - #$error = $record->add; #depriciated - - $error = $record->delete; - #$error = $record->del; #depriciated - - $error = $new_record->replace($old_record); - #$error = $new_record->rep($old_record); #depriciated - - $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'; #as a subroutine - @fields = $record->fields; #as a method call - - -=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 CONSTRUCTORS - -=over 4 - -=item new [ TABLE, ] HASHREF - -Creates a new record. It doesn't store it in the database, though. See -L<"insert"> 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. - -TABLE can only be omitted when a dervived class overrides the table method. - -=cut - -sub new { - my $proto = shift; - my $class = ref($proto) || $proto; - my $self = {}; - bless ($self, $class); - - $self->{'Table'} = shift unless defined ( $self->table ); - - my $hashref = $self->{'Hash'} = shift; - - foreach my $field ( $self->fields ) { - $hashref->{$field}='' unless defined $hashref->{$field}; - #trim the '$' and ',' from money fields for Pg (belong HERE?) - #(what about Pg i18n?) - if ( datasrc =~ m/Pg/ - && $self->dbdef_table->column($field)->type eq 'money' ) { - ${$hashref}{$field} =~ s/^\$//; - ${$hashref}{$field} =~ s/\,//; - } - } - - $self; -} - -sub create { - my $proto = shift; - my $class = ref($proto) || $proto; - my $self = {}; - bless ($self, $class); - if ( defined $self->table ) { - cluck "create constructor is depriciated, use new!"; - $self->new(@_); - } else { - croak "FS::Record::create called (not from a subclass)!"; - } -} - -=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::TABLE' objects if that -module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record -objects. - -=cut - -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 { - $record->{$_} eq '' - ? ( datasrc =~ m/Pg/ - ? "$_ IS NULL" - : "( $_ IS NULL OR $_ = \"\" )" - ) - : "$_ = ". _quote($record->{$_},$table,$_) - } @fields - ) : '' - ); - $sth=$dbh->prepare($statement) - or croak $dbh->errstr; #is that a little too harsh? hmm. - #warn $statement #if $debug # or some such; - - if ( eval ' scalar(@FS::'. $table. '::ISA);' ) { - map { - eval 'new FS::'. $table. ' ( $sth->fetchrow_hashref );'; - } ( 1 .. $sth->execute ); - } else { - cluck "qsearch: warning: FS::$table not loaded; returning generic FS::Record objects"; - map { - new FS::Record ($table,$sth->fetchrow_hashref); - } ( 1 .. $sth->execute ); - } - -} - -=item qsearchs TABLE, HASHREF - -Same as qsearch, except that 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 "warning: Multiple records in scalar search!" if scalar(@result) > 1; - #should warn more vehemently if the search was on a primary key? - $result[0]; -} - -=back - -=head1 METHODS - -=over 4 - -=item table - -Returns the table name. - -=cut - -sub table { -# cluck "warning: FS::Record::table depriciated; supply one in subclass!"; - my $self = shift; - $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 { - my $self = shift; - $self->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 { - my $self = shift; - $self->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 insert - -Inserts this record to the database. If there is an error, returns the error, -otherwise returns false. - -=cut - -sub insert { - my $self = shift; - - my $error = $self->check; - return $error if $error; - - #single-field unique keys are given a value if false - #(like MySQL's AUTO_INCREMENT) - foreach ( $self->dbdef_table->unique->singles ) { - $self->unique($_) unless $self->getfield($_); - } - #and also the primary key - my $primary_key = $self->dbdef_table->primary_key; - $self->unique($primary_key) - if $primary_key && ! $self->getfield($primary_key); - - my @fields = - grep defined($self->getfield($_)) && $self->getfield($_) ne "", - $self->fields - ; - - my $statement = "INSERT INTO ". $self->table. " ( ". - join(', ',@fields ). - ") VALUES (". - join(', ',map(_quote($self->getfield($_),$self->table,$_), @fields)). - ")" - ; - my $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'; - local $SIG{PIPE} = 'IGNORE'; - - $sth->execute or return $sth->errstr; - - ''; -} - -=item add - -Depriciated (use insert instead). - -=cut - -sub add { - cluck "warning: FS::Record::add depriciated!"; - insert @_; #call method in this scope -} - -=item delete - -Delete this record from the database. If there is an error, returns the error, -otherwise returns false. - -=cut - -sub delete { - my $self = shift; - - my($statement)="DELETE FROM ". $self->table. " WHERE ". join(' AND ', - map { - $self->getfield($_) eq '' - #? "( $_ IS NULL OR $_ = \"\" )" - ? ( datasrc =~ m/Pg/ - ? "$_ IS NULL" - : "( $_ IS NULL OR $_ = \"\" )" - ) - : "$_ = ". _quote($self->getfield($_),$self->table,$_) - } ( $self->dbdef_table->primary_key ) - ? ( $self->dbdef_table->primary_key) - : $self->fields - ); - my $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'; - local $SIG{PIPE} = 'IGNORE'; - - my $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 del - -Depriciated (use delete instead). - -=cut - -sub del { - cluck "warning: FS::Record::del depriciated!"; - &delete(@_); #call method in this scope -} - -=item replace 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 replace { - my ( $new, $old ) = ( shift, shift ); - - my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields; - unless ( @diff ) { - carp "warning: records identical"; - return ''; - } - - return "Records not in same table!" unless $new->table eq $old->table; - - my $primary_key = $old->dbdef_table->primary_key; - return "Can't change $primary_key" - if $primary_key - && ( $old->getfield($primary_key) ne $new->getfield($primary_key) ); - - my $error = $new->check; - return $error if $error; - - my $statement = "UPDATE ". $old->table. " SET ". join(', ', - map { - "$_ = ". _quote($new->getfield($_),$old->table,$_) - } @diff - ). ' WHERE '. - join(' AND ', - map { - $old->getfield($_) eq '' - #? "( $_ IS NULL OR $_ = \"\" )" - ? ( datasrc =~ m/Pg/ - ? "$_ IS NULL" - : "( $_ IS NULL OR $_ = \"\" )" - ) - : "$_ = ". _quote($old->getfield($_),$old->table,$_) - } ( $primary_key ? ( $primary_key ) : $old->fields ) - ) - ; - my $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'; - local $SIG{PIPE} = 'IGNORE'; - - my $rc = $sth->execute or return $sth->errstr; - #not portable #return "Record not found (or records identical)." if $rc eq "0E0"; - - ''; - -} - -=item rep - -Depriciated (use replace instead). - -=cut - -sub rep { - cluck "warning: FS::Record::rep depriciated!"; - replace @_; #call method in this scope -} - -=item check - -Not yet implemented, croaks. Derived classes should provide a check method. - -=cut - -sub check { - confess "FS::Record::check not implemented; supply one in subclass!"; -} - -=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->getfield($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->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) =~ /^(\d*)$/ - or return "Illegal (numeric) $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)=@_; - $self->setfield($field, 0) if $self->getfield($field) eq ''; - $self->getfield($field) =~ /^(\-)? ?(\d*)(\.\d{2})?$/ - or return "Illegal (money) $field: ". $self->getfield($field); - #$self->setfield($field, "$1$2$3" || 0); - $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->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)=@_; - $self->getfield($field) =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/]*)$/ - or return "Illegal (text) $field: ". $self->getfield($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->getfield($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->getfield($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: ". $self->getfield($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->getfield($field); - $self->setfield($field,$1); - ''; -} - -=item fields [ TABLE ] - -This can be used as both a subroutine and a method call. It returns a list -of the columns in this record's table, or an explicitly specified table. -(See L). - -=cut - -# Usage: @fields = fields($table); -# @fields = $record->fields; -sub fields { - my $something = shift; - my $table; - if ( ref($something) ) { - $table = $something->table; - } else { - $table = $something; - } - #croak "Usage: \@fields = fields(\$table)\n or: \@fields = \$record->fields" unless $table; - my($table_obj) = $dbdef->table($table); - croak "Unknown table $table" unless $table_obj; - $table_obj->columns; -} - -=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 "warning: hfields is depriciated"; - my($table)=@_; - my(%hash); - foreach (fields($table)) { - $hash{$_}=1; - } - \%hash; -} - -#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 VERSION - -$Id: Record.pm,v 1.17 1999-07-17 01:34:25 ivan Exp $ - -=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 whith 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. - -Probably should borrow/use some dbdef methods where appropriate (like sub -fields) - -=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 - -$Log: Record.pm,v $ -Revision 1.17 1999-07-17 01:34:25 ivan -s/croak/confess/; in check method - -Revision 1.16 1999/04/10 07:03:38 ivan -return the value with ut_* error messages, to assist in debugging - -Revision 1.15 1999/04/08 12:08:59 ivan -fix up PostgreSQL money fields so you can actually use them as numbers. bah. - -Revision 1.14 1999/04/07 14:58:31 ivan -more kludges to get around different null/empty handling in Perl vs. MySQL vs. -PostgreSQL etc. - -Revision 1.13 1999/03/29 11:55:43 ivan -eliminate warnings in ut_money - -Revision 1.12 1999/01/25 12:26:06 ivan -yet more mod_perl stuff - -Revision 1.11 1999/01/18 09:22:38 ivan -changes to track email addresses for email invoicing - -Revision 1.10 1998/12/29 11:59:33 ivan -mostly properly OO, some work still to be done with svc_ stuff - -Revision 1.9 1998/11/21 07:26:45 ivan -"Records identical" carp tells us it is just a warning. - -Revision 1.8 1998/11/15 11:02:04 ivan -bugsquash - -Revision 1.7 1998/11/15 10:56:31 ivan -qsearch gets sames "IS NULL" semantics as other WHERE clauses - -Revision 1.6 1998/11/15 05:31:03 ivan -bugfix for new config layout - -Revision 1.5 1998/11/13 09:56:51 ivan -change configuration file layout to support multiple distinct databases (with -own set of config files, export, etc.) - -Revision 1.4 1998/11/10 07:45:25 ivan -doc clarification - -Revision 1.2 1998/11/07 05:17:18 ivan -In sub new, Pg wrapper for money fields from dbdef (FS::Record::fields $table), -not keys of supplied hashref. - - -=cut - -1; - diff --git a/site_perl/SSH.pm b/site_perl/SSH.pm deleted file mode 100644 index d5a0df654..000000000 --- a/site_perl/SSH.pm +++ /dev/null @@ -1,157 +0,0 @@ -package FS::SSH; - -use strict; -use vars qw(@ISA @EXPORT_OK $ssh $scp); -use Exporter; -use IPC::Open2; -use IPC::Open3; - -@ISA = qw(Exporter); -@EXPORT_OK = qw(ssh scp issh iscp sshopen2 sshopen3); - -$ssh="ssh"; -$scp="scp"; - -=head1 NAME - -FS::SSH - Subroutines to call ssh and scp - -=head1 SYNOPSIS - - use FS::SSH qw(ssh scp issh iscp sshopen2 sshopen3); - - ssh($host, $command); - - issh($host, $command); - - scp($source, $destination); - - iscp($source, $destination); - - sshopen2($host, $reader, $writer, $command); - - sshopen3($host, $reader, $writer, $error, $command); - -=head1 DESCRIPTION - - Simple wrappers around ssh and scp commands. - -=head1 SUBROUTINES - -=over 4 - -=item ssh HOST, COMMAND - -Calls ssh in batch mode. - -=cut - -sub ssh { - my($host,$command)=@_; - my(@cmd)=($ssh, "-o", "BatchMode yes", $host, $command); -# print join(' ',@cmd),"\n"; -#0; - system(@cmd); -} - -=item issh HOST, COMMAND - -Prints the ssh command to be executed, waits for the user to confirm, and -(optionally) executes the command. - -=cut - -sub issh { - my($host,$command)=@_; - my(@cmd)=($ssh, $host, $command); - print join(' ',@cmd),"\n"; - if ( &_yesno ) { - ###print join(' ',@cmd),"\n"; - system(@cmd); - } -} - -=item scp SOURCE, DESTINATION - -Calls scp in batch mode. - -=cut - -sub scp { - my($src,$dest)=@_; - my(@cmd)=($scp,"-Bprq",$src,$dest); -# print join(' ',@cmd),"\n"; -#0; - system(@cmd); -} - -=item iscp SOURCE, DESTINATION - -Prints the scp command to be executed, waits for the user to confirm, and -(optionally) executes the command. - -=cut - -sub iscp { - my($src,$dest)=@_; - my(@cmd)=($scp,"-pr",$src,$dest); - print join(' ',@cmd),"\n"; - if ( &_yesno ) { - ###print join(' ',@cmd),"\n"; - system(@cmd); - } -} - -=item sshopen2 HOST, READER, WRITER, COMMAND - -Connects the supplied filehandles to the ssh process (in batch mode). - -=cut - -sub sshopen2 { - my($host,$reader,$writer,$command)=@_; - open2($reader,$writer,$ssh,'-o','Batchmode yes',$host,$command); -} - -=item sshopen3 HOST, WRITER, READER, ERROR, COMMAND - -Connects the supplied filehandles to the ssh process (in batch mode). - -=cut - -sub sshopen3 { - my($host,$writer,$reader,$error,$command)=@_; - open3($writer,$reader,$error,$ssh,'-o','Batchmode yes',$host,$command); -} - -sub _yesno { - print "Proceed [y/N]:"; - my($x)=scalar(); - $x =~ /^y/i; -} - -=head1 BUGS - -Not OO. - -scp stuff should transparantly use rsync-over-ssh instead. - -=head1 SEE ALSO - -L, L, L, L - -=head1 HISTORY - -ivan@voicenet.com 97-jul-17 - -added sshopen2 and sshopen3 ivan@sisd.com 98-mar-9 - -added iscp ivan@sisd.com 98-jul-25 -now iscp asks y/n, issh and took out path ivan@sisd.com 98-jul-30 - -pod ivan@sisd.com 98-sep-21 - -=cut - -1; - diff --git a/site_perl/UID.pm b/site_perl/UID.pm deleted file mode 100644 index 889ccb65f..000000000 --- a/site_perl/UID.pm +++ /dev/null @@ -1,326 +0,0 @@ -package FS::UID; - -use strict; -use vars qw( - @ISA @EXPORT_OK $cgi $dbh $freeside_uid $user - $conf_dir $secrets $datasrc $db_user $db_pass %callback -); -use subs qw( - getsecrets cgisetotaker -); -use Exporter; -use Carp; -use DBI; -use FS::Conf; - -@ISA = qw(Exporter); -@EXPORT_OK = qw(checkeuid checkruid swapuid cgisuidsetup - adminsuidsetup getotaker dbh datasrc getsecrets ); - -$freeside_uid = scalar(getpwnam('freeside')); - -$conf_dir = "/usr/local/etc/freeside/"; - -=head1 NAME - -FS::UID - Subroutines for database login and assorted other stuff - -=head1 SYNOPSIS - - use FS::UID qw(adminsuidsetup cgisuidsetup dbh datasrc getotaker - checkeuid checkruid swapuid); - - adminsuidsetup $user; - - $cgi = new CGI; - $dbh = cgisuidsetup($cgi); - - $dbh = dbh; - - $datasrc = datasrc; - -=head1 DESCRIPTION - -Provides a hodgepodge of subroutines. - -=head1 SUBROUTINES - -=over 4 - -=item adminsuidsetup USER - -Sets the user to USER (see config.html from the base documentation). -Cleans the environment. -Make sure the script is running as freeside, or setuid freeside. -Opens a connection to the database. -Swaps real and effective UIDs. -Runs any defined callbacks (see below). -Returns the DBI database handle (usually you don't need this). - -=cut - -sub adminsuidsetup { - - $user = shift; - croak "fatal: adminsuidsetup called without arguements" unless $user; - - $ENV{'PATH'} ='/usr/local/bin:/usr/bin:/usr/ucb:/bin'; - $ENV{'SHELL'} = '/bin/sh'; - $ENV{'IFS'} = " \t\n"; - $ENV{'CDPATH'} = ''; - $ENV{'ENV'} = ''; - $ENV{'BASH_ENV'} = ''; - - croak "Not running uid freeside!" unless checkeuid(); - getsecrets; - $dbh = DBI->connect($datasrc,$db_user,$db_pass, { - 'AutoCommit' => 'true', - 'ChopBlanks' => 'true', - } ) or die "DBI->connect error: $DBI::errstr\n"; - - swapuid(); #go to non-privledged user if running setuid freeside - - foreach ( keys %callback ) { - &{$callback{$_}}; - } - - $dbh; -} - -=item cgisuidsetup CGI_object - -Stores the CGI (see L) object for later use. (CGI::Base is depriciated) -Runs adminsuidsetup. - -=cut - -sub cgisuidsetup { - $cgi=shift; - if ( $cgi->isa('CGI::Base') ) { - carp "Use of CGI::Base is depriciated"; - } elsif ( ! $cgi->isa('CGI') ) { - croak "Pass a CGI object to cgisuidsetup!"; - } - cgisetotaker; - adminsuidsetup($user); -} - -=item cgi - -Returns the CGI (see L) object. - -=cut - -sub cgi { - $cgi; -} - -=item dbh - -Returns the DBI database handle. - -=cut - -sub dbh { - $dbh; -} - -=item datasrc - -Returns the DBI data source. - -=cut - -sub datasrc { - $datasrc; -} - -#hack for web demo -#sub setdbh { -# $dbh=$_[0]; -#} - -sub suidsetup { - croak "suidsetup depriciated"; -} - -=item getotaker - -Returns the current Freeside user. - -=cut - -sub getotaker { - $user; -} - -=item cgisetotaker - -Sets and returns the CGI REMOTE_USER. $cgi should be defined as a CGI.pm -object. Support for CGI::Base and derived classes is depriciated. - -=cut - -sub cgisetotaker { - if ( $cgi && $cgi->isa('CGI::Base') && defined $cgi->var('REMOTE_USER')) { - carp "Use of CGI::Base is depriciated"; - $user = lc ( $cgi->var('REMOTE_USER') ); - } elsif ( $cgi && $cgi->isa('CGI') && defined $cgi->remote_user ) { - $user = lc ( $cgi->remote_user ); - } else { - die "fatal: Can't get REMOTE_USER!"; - } - $user; -} - -=item checkeuid - -Returns true if effective UID is that of the freeside user. - -=cut - -sub checkeuid { - ( $> == $freeside_uid ); -} - -=item checkruid - -Returns true if the real UID is that of the freeside user. - -=cut - -sub checkruid { - ( $< == $freeside_uid ); -} - -=item swapuid - -Swaps real and effective UIDs. - -=cut - -sub swapuid { - ($<,$>) = ($>,$<) if $< != $>; -} - -=item getsecrets [ USER ] - -Sets the user to USER, if supplied. -Sets and returns the DBI datasource, username and password for this user from -the `/usr/local/etc/freeside/mapsecrets' file. - -=cut - -sub getsecrets { - my($setuser) = shift; - $user = $setuser if $setuser; - die "No user!" unless $user; - my($conf) = new FS::Conf $conf_dir; - my($line) = grep /^\s*$user\s/, $conf->config('mapsecrets'); - die "User not found in mapsecrets!" unless $line; - $line =~ /^\s*$user\s+(.*)$/; - $secrets = $1; - die "Illegal mapsecrets line for user?!" unless $secrets; - ($datasrc, $db_user, $db_pass) = $conf->config($secrets) - or die "Can't get secrets: $!"; - $FS::Conf::default_dir = $conf_dir. "/conf.$datasrc"; - ($datasrc, $db_user, $db_pass); -} - -=back - -=head1 CALLBACKS - -Warning: this interface is likely to change in future releases. - -A package can install a callback to be run in adminsuidsetup by putting a -coderef into the hash %FS::UID::callback : - - $coderef = sub { warn "Hi, I'm returning your call!" }; - $FS::UID::callback{'Package::Name'}; - -=head1 VERSION - -$Id: UID.pm,v 1.11 1999-04-14 07:58:39 ivan Exp $ - -=head1 BUGS - -Too many package-global variables. - -Not OO. - -No capabilities yet. When mod_perl and Authen::DBI are implemented, -cgisuidsetup will go away as well. - -Goes through contortions to support non-OO syntax with multiple datasrc's. - -Callbacks are inelegant. - -=head1 SEE ALSO - -L, L, L, config.html from the base documentation. - -=head1 HISTORY - -ivan@voicenet.com 97-jun-4 - 9 - -untaint otaker ivan@voicenet.com 97-jul-7 - -generalize and auto-get uid (getotaker still needs to be db'ed) -ivan@sisd.com 97-nov-10 - -&cgisuidsetup logs into database. other cleaning. -ivan@sisd.com 97-nov-22,23 - -&adminsuidsetup logs into database with otaker='freeside' (for -automated tasks like billing) -ivan@sisd.com 97-dec-13 - -added sub datasrc for fs-setup ivan@sisd.com 98-feb-21 - -datasrc, user and pass now come from conf/secrets ivan@sisd.com 98-jun-28 - -added ChopBlanks to DBI call (see man DBI) ivan@sisd.com 98-aug-16 - -pod, use FS::Conf, implemented cgisuidsetup as adminsuidsetup, -inlined suidsetup -ivan@sisd.com 98-sep-12 - -$Log: UID.pm,v $ -Revision 1.11 1999-04-14 07:58:39 ivan -export getsecrets from FS::UID instead of calling it explicitly - -Revision 1.10 1999/04/12 22:41:09 ivan -bugfix; $user is a global (yuck) - -Revision 1.9 1999/04/12 21:09:39 ivan -force username to lowercase - -Revision 1.8 1999/02/23 07:23:23 ivan -oops, don't comment out &swapuid in &adminsuidsetup! - -Revision 1.7 1999/01/18 09:22:40 ivan -changes to track email addresses for email invoicing - -Revision 1.6 1998/11/15 05:27:48 ivan -bugfix for new configuration layout - -Revision 1.5 1998/11/15 00:51:51 ivan -eliminated some warnings on certain fatal errors (well, it is less confusing) - -Revision 1.4 1998/11/13 09:56:52 ivan -change configuration file layout to support multiple distinct databases (with -own set of config files, export, etc.) - -Revision 1.3 1998/11/08 10:45:42 ivan -got sub cgi for FS::CGI - -Revision 1.2 1998/11/08 09:38:43 ivan -cgisuidsetup complains if you pass it a isa CGI::Base instead of an isa CGI -(first step in migrating from CGI-modules to CGI.pm) - - -=cut - -1; - diff --git a/site_perl/agent.pm b/site_perl/agent.pm deleted file mode 100644 index dab157b3f..000000000 --- a/site_perl/agent.pm +++ /dev/null @@ -1,168 +0,0 @@ -package FS::agent; - -use strict; -use vars qw( @ISA ); -use FS::Record qw( qsearch qsearchs ); -use FS::cust_main; -use FS::agent_type; - -@ISA = qw( FS::Record ); - -=head1 NAME - -FS::agent - Object methods for agent records - -=head1 SYNOPSIS - - use FS::agent; - - $record = new FS::agent \%hash; - $record = new FS::agent { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - - $agent_type = $record->agent_type; - - $hashref = $record->pkgpart_hashref; - #may purchase $pkgpart if $hashref->{$pkgpart}; - -=head1 DESCRIPTION - -An FS::agent object represents an agent. Every customer has an agent. Agents -can be used to track things like resellers or salespeople. FS::agent inherits -from FS::Record. The following fields are currently supported: - -=over 4 - -=item agemtnum - primary key (assigned automatically for new agents) - -=item agent - Text name of this agent - -=item typenum - Agent type. See L - -=item prog - For future use. - -=item freq - For future use. - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new agent. To add the agent to the database, see L<"insert">. - -=cut - -sub table { 'agent'; } - -=item insert - -Adds this agent to the database. If there is an error, returns the error, -otherwise returns false. - -=item delete - -Deletes this agent from the database. Only agents with no customers can be -deleted. If there is an error, returns the error, otherwise returns false. - -=cut - -sub delete { - my $self = shift; - - return "Can't delete an agent with customers!" - if qsearch( 'cust_main', { 'agentnum' => $self->agentnum } ); - - $self->SUPER::delete; -} - -=item replace OLD_RECORD - -Replaces OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -=item check - -Checks all fields to make sure this is a valid agent. If there is an error, -returns the error, otherwise returns false. Called by the insert and replace -methods. - -=cut - -sub check { - my $self = shift; - - my $error = - $self->ut_numbern('agentnum') - || $self->ut_text('agent') - || $self->ut_number('typenum') - || $self->ut_numbern('freq') - || $self->ut_textn('prog') - ; - return $error if $error; - - return "Unknown typenum!" - unless $self->agent_type; - - ''; - -} - -=item agent_type - -Returns the FS::agent_type object (see L) for this agent. - -=cut - -sub agent_type { - my $self = shift; - qsearchs( 'agent_type', { 'typenum' => $self->typenum } ); -} - -=item pkgpart_hashref - -Returns a hash reference. The keys of the hash are pkgparts. The value is -true iff this agent may purchase the specified package definition. See -L. - -=cut - -sub pkgpart_hashref { - my $self = shift; - $self->agent_type->pkgpart_hashref; -} - -=back - -=head1 VERSION - -$Id: agent.pm,v 1.5 1999-07-20 10:37:05 ivan Exp $ - -=head1 BUGS - -=head1 SEE ALSO - -L, L, L, L, -schema.html from the base documentation. - -=head1 HISTORY - -Class dealing with agent (resellers) - -ivan@sisd.com 97-nov-13, 97-dec-10 - -pod, added check in ->delete ivan@sisd.com 98-sep-22 - -=cut - -1; - diff --git a/site_perl/agent_type.pm b/site_perl/agent_type.pm deleted file mode 100644 index 5b82cc3d6..000000000 --- a/site_perl/agent_type.pm +++ /dev/null @@ -1,192 +0,0 @@ -package FS::agent_type; - -use strict; -use vars qw( @ISA ); -use FS::Record qw( qsearch ); -use FS::agent; -use FS::type_pkgs; - -@ISA = qw( FS::Record ); - -=head1 NAME - -FS::agent_type - Object methods for agent_type records - -=head1 SYNOPSIS - - use FS::agent_type; - - $record = new FS::agent_type \%hash; - $record = new FS::agent_type { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - - $hashref = $record->pkgpart_hashref; - #may purchase $pkgpart if $hashref->{$pkgpart}; - - @type_pkgs = $record->type_pkgs; - - @pkgparts = $record->pkgpart; - -=head1 DESCRIPTION - -An FS::agent_type object represents an agent type. Every agent (see -L) has an agent type. Agent types define which packages (see -L) may be purchased by customers (see L), via -FS::type_pkgs records (see L). FS::agent_type inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item typenum - primary key (assigned automatically for new agent types) - -=item atype - Text name of this agent type - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new agent type. To add the agent type to the database, see -L<"insert">. - -=cut - -sub table { 'agent_type'; } - -=item insert - -Adds this agent type to the database. If there is an error, returns the error, -otherwise returns false. - -=item delete - -Deletes this agent type from the database. Only agent types with no agents -can be deleted. If there is an error, returns the error, otherwise returns -false. - -=cut - -sub delete { - my $self = shift; - - return "Can't delete an agent_type with agents!" - if qsearch( 'agent', { 'typenum' => $self->typenum } ); - - $self->SUPER::delete; -} - -=item replace OLD_RECORD - -Replaces OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -=item check - -Checks all fields to make sure this is a valid agent type. If there is an -error, returns the error, otherwise returns false. Called by the insert and -replace methods. - -=cut - -sub check { - my $self = shift; - - $self->ut_numbern('typenum') - or $self->ut_text('atype'); - -} - -=item pkgpart_hashref - -Returns a hash reference. The keys of the hash are pkgparts. The value is -true iff this agent may purchase the specified package definition. See -L. - -=cut - -sub pkgpart_hashref { - my $self = shift; - my %pkgpart; - #$pkgpart{$_}++ foreach $self->pkgpart; - # not compatible w/5.004_04 (fixed in 5.004_05) - foreach ( $self->pkgpart ) { $pkgpart{$_}++; } - \%pkgpart; -} - -=item type_pkgs - -Returns all FS::type_pkgs objects (see L) for this agent type. - -=cut - -sub type_pkgs { - my $self = shift; - qsearch('type_pkgs', { 'typenum' => $self->typenum } ); -} - -=item pkgpart - -Returns the pkgpart of all package definitions (see L) for this -agent type. - -=cut - -sub pkgpart { - my $self = shift; - map $_->pkgpart, $self->type_pkgs; -} - -=back - -=head1 VERSION - -$Id: agent_type.pm,v 1.4 1999-07-21 06:32:08 ivan Exp $ - -=head1 BUGS - -=head1 SEE ALSO - -L, L, L, L, -L, schema.html from the base documentation. - -=head1 HISTORY - -Class for the different sets of allowable packages you can assign to an -agent. - -ivan@sisd.com 97-nov-13 - -ut_ FS::Record methods -ivan@sisd.com 97-dec-10 - -Changed 'type' to 'atype' because Pg6.3 reserves the type word - bmccane@maxbaud.net 98-apr-3 - -pod, added check in delete ivan@sisd.com 98-sep-21 - -$Log: agent_type.pm,v $ -Revision 1.4 1999-07-21 06:32:08 ivan -workaround for syntax not compatible w/5.004_04 (ok in 5.004_05) - -Revision 1.3 1999/07/20 10:37:05 ivan -cleaned up the new one-screen signup bits in htdocs/edit/cust_main.cgi to -prepare for a signup server - -Revision 1.2 1998/12/29 11:59:35 ivan -mostly properly OO, some work still to be done with svc_ stuff - - -=cut - -1; - diff --git a/site_perl/cust_bill.pm b/site_perl/cust_bill.pm deleted file mode 100644 index 0e87755ac..000000000 --- a/site_perl/cust_bill.pm +++ /dev/null @@ -1,482 +0,0 @@ -package FS::cust_bill; - -use strict; -use vars qw( @ISA $conf $add1 $add2 $add3 $add4 ); -use Date::Format; -use FS::Record qw( qsearch qsearchs ); -use FS::cust_main; -use FS::cust_bill_pkg; -use FS::cust_credit; -use FS::cust_pay; -use FS::cust_pkg; - -@ISA = qw( FS::Record ); - -#ask FS::UID to run this stuff for us later -$FS::UID::callback{'FS::cust_bill'} = sub { - $conf = new FS::Conf; - ( $add1, $add2, $add3, $add4 ) = ( $conf->config('address'), '', '', '', '' ); -}; - -=head1 NAME - -FS::cust_bill - Object methods for cust_bill records - -=head1 SYNOPSIS - - use FS::cust_bill; - - $record = new FS::cust_bill \%hash; - $record = new FS::cust_bill { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - - ( $total_previous_balance, @previous_cust_bill ) = $record->previous; - - @cust_bill_pkg_objects = $cust_bill->cust_bill_pkg; - - ( $total_previous_credits, @previous_cust_credit ) = $record->cust_credit; - - @cust_pay_objects = $cust_bill->cust_pay; - - @lines = $cust_bill->print_text; - @lines = $cust_bill->print_text $time; - -=head1 DESCRIPTION - -An FS::cust_bill object represents an invoice. FS::cust_bill inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item invnum - primary key (assigned automatically for new invoices) - -=item custnum - customer (see L) - -=item _date - specified as a UNIX timestamp; see L. Also see -L and L for conversion functions. - -=item charged - amount of this invoice - -=item owed - amount still outstanding on this invoice, which is charged minus -all payments (see L). - -=item printed - how many times this invoice has been printed automatically -(see L). - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new invoice. To add the invoice to the database, see L<"insert">. -Invoices are normally created by calling the bill method of a customer object -(see L). - -=cut - -sub table { 'cust_bill'; } - -=item insert - -Adds this invoice to the database ("Posts" the invoice). If there is an error, -returns the error, otherwise returns false. - -When adding new invoices, owed must be charged (or null, in which case it is -automatically set to charged). - -=cut - -sub insert { - my $self = shift; - - $self->owed( $self->charged ) if $self->owed eq ''; - return "owed != charged!" - unless $self->owed == $self->charged; - - $self->SUPER::insert; -} - -=item delete - -Currently unimplemented. I don't remove invoices because there would then be -no record you ever posted this invoice (which is bad, no?) - -=cut - -sub delete { - return "Can't remove invoice!" -} - -=item replace OLD_RECORD - -Replaces the OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -Only owed and printed may be changed. Owed is normally updated by creating and -inserting a payment (see L). Printed is normally updated by -calling the collect method of a customer object (see L). - -=cut - -sub replace { - my( $new, $old ) = ( shift, shift ); - return "Can't change custnum!" unless $old->custnum == $new->custnum; - #return "Can't change _date!" unless $old->_date eq $new->_date; - return "Can't change _date!" unless $old->_date == $new->_date; - return "Can't change charged!" unless $old->charged == $new->charged; - return "(New) owed can't be > (new) charged!" if $new->owed > $new->charged; - - $new->SUPER::replace($old); -} - -=item check - -Checks all fields to make sure this is a valid invoice. If there is an error, -returns the error, otherwise returns false. Called by the insert and replace -methods. - -=cut - -sub check { - my $self = shift; - - my $error = - $self->ut_numbern('invnum') - || $self->ut_number('custnum') - || $self->ut_numbern('_date') - || $self->ut_money('charged') - || $self->ut_money('owed') - || $self->ut_numbern('printed') - ; - return $error if $error; - - return "Unknown customer" - unless qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); - - $self->_date(time) unless $self->_date; - - $self->printed(0) if $self->printed eq ''; - - ''; #no error -} - -=item previous - -Returns a list consisting of the total previous balance for this customer, -followed by the previous outstanding invoices (as FS::cust_bill objects also). - -=cut - -sub previous { - my $self = shift; - my $total = 0; - my @cust_bill = sort { $a->_date <=> $b->_date } - grep { $_->owed != 0 && $_->_date < $self->_date } - qsearch( 'cust_bill', { 'custnum' => $self->custnum } ) - ; - foreach ( @cust_bill ) { $total += $_->owed; } - $total, @cust_bill; -} - -=item cust_bill_pkg - -Returns the line items (see L) for this invoice. - -=cut - -sub cust_bill_pkg { - my $self = shift; - qsearch( 'cust_bill_pkg', { 'invnum' => $self->invnum } ); -} - -=item cust_credit - -Returns a list consisting of the total previous credited (see -L) for this customer, followed by the previous outstanding -credits (FS::cust_credit objects). - -=cut - -sub cust_credit { - my $self = shift; - my $total = 0; - my @cust_credit = sort { $a->_date <=> $b->date } - grep { $_->credited != 0 && $_->_date < $self->_date } - qsearch('cust_credit', { 'custnum' => $self->custnum } ) - ; - foreach (@cust_credit) { $total += $_->credited; } - $total, @cust_credit; -} - -=item cust_pay - -Returns all payments (see L) for this invoice. - -=cut - -sub cust_pay { - my $self = shift; - sort { $a->_date <=> $b->date } - qsearch( 'cust_pay', { 'invnum' => $self->invnum } ) - ; -} - -=item print_text [TIME]; - -Returns an ASCII invoice, as a list of lines. - -TIME an optional value used to control the printing of overdue messages. The -default is now. It isn't the date of the invoice; that's the `_date' field. -It is specified as a UNIX timestamp; see L. Also see -L and L for conversion functions. - -=cut - -sub print_text { - - my( $self, $today ) = ( shift, shift ); - $today ||= time; - my $invnum = $self->invnum; - my $cust_main = qsearchs('cust_main', { 'custnum', $self->custnum } ); - $cust_main->payname( $cust_main->first. ' '. $cust_main->getfield('last') ) - unless $cust_main->payname; - - my( $pr_total, @pr_cust_bill ) = $self->previous; #previous balance - my( $cr_total, @cr_cust_credit ) = $self->cust_credit; #credits - my $balance_due = $self->owed + $pr_total - $cr_total; - - #overdue? - my $overdue = ( - $balance_due > 0 - && $today > $self->_date - && $self->printed > 1 - ); - - #printing bits here (yuck!) - - my @collect = (); - - my($description,$amount); - my(@buf); - - #format address - my($l,@address)=(0,'','','','','','',''); - $address[$l++] = - $cust_main->payname. - ( ( $cust_main->payby eq 'BILL' ) && $cust_main->payinfo - ? " (P.O. #". $cust_main->payinfo. ")" - : '' - ) - ; - $address[$l++]=$cust_main->company if $cust_main->company; - $address[$l++]=$cust_main->address1; - $address[$l++]=$cust_main->address2 if $cust_main->address2; - $address[$l++]=$cust_main->city. ", ". $cust_main->state. " ". - $cust_main->zip; - $address[$l++]=$cust_main->country unless $cust_main->country eq 'US'; - - #previous balance - foreach ( @pr_cust_bill ) { - push @buf, ( - "Previous Balance, Invoice #". $_->invnum. - " (". time2str("%x",$_->_date). ")", - '$'. sprintf("%10.2f",$_->owed) - ); - } - if (@pr_cust_bill) { - push @buf,('','-----------'); - push @buf,('Total Previous Balance','$' . sprintf("%10.2f",$pr_total ) ); - push @buf,('',''); - } - - #new charges - foreach ( $self->cust_bill_pkg ) { - - if ( $_->pkgnum ) { - - my($cust_pkg)=qsearchs('cust_pkg', { 'pkgnum', $_->pkgnum } ); - my($part_pkg)=qsearchs('part_pkg',{'pkgpart'=>$cust_pkg->pkgpart}); - my($pkg)=$part_pkg->pkg; - - if ( $_->setup != 0 ) { - push @buf, ( "$pkg Setup",'$' . sprintf("%10.2f",$_->setup) ); - push @buf, map { " ". $_->[0]. ": ". $_->[1], '' } $cust_pkg->labels; - } - - if ( $_->recur != 0 ) { - push @buf, ( - "$pkg (" . time2str("%x",$_->sdate) . " - " . - time2str("%x",$_->edate) . ")", - '$' . sprintf("%10.2f",$_->recur) - ); - push @buf, map { " ". $_->[0]. ": ". $_->[1], '' } $cust_pkg->labels; - } - - } else { #pkgnum Tax - push @buf,("Tax",'$' . sprintf("%10.2f",$_->setup) ) - if $_->setup != 0; - } - } - - push @buf,('','-----------'); - push @buf,('Total New Charges', - '$' . sprintf("%10.2f",$self->charged) ); - push @buf,('',''); - - push @buf,('','-----------'); - push @buf,('Total Charges', - '$' . sprintf("%10.2f",$self->charged + $pr_total) ); - push @buf,('',''); - - #credits - foreach ( @cr_cust_credit ) { - push @buf,( - "Credit #". $_->crednum. " (" . time2str("%x",$_->_date) .")", - '$' . sprintf("%10.2f",$_->credited) - ); - } - - #get & print payments - foreach ( $self->cust_pay ) { - push @buf,( - "Payment received ". time2str("%x",$_->_date ), - '$' . sprintf("%10.2f",$_->paid ) - ); - } - - #balance due - push @buf,('','-----------'); - push @buf,('Balance Due','$' . - sprintf("%10.2f",$self->owed + $pr_total - $cr_total ) ); - - #now print - - my $tot_lines = 50; #should be configurable - #header is 17 lines - my $tot_pages = int( scalar(@buf) / ( 2 * ( $tot_lines - 17 ) ) ); - $tot_pages++ if scalar(@buf) % ( 2 * ( $tot_lines - 17 ) ); - - my $page = 1; - my $lines; - while (@buf) { - $lines = $tot_lines; - my @header = &header( - $page, $tot_pages, $self->_date, $self->invnum, @address - ); - push @collect, @header; - $lines -= scalar(@header); - - while ( $lines-- && @buf ) { - $description=shift(@buf); - $amount=shift(@buf); - push @collect, myswrite($description, $amount); - } - $page++; - } - while ( $lines-- ) { - push @collect, myswrite('', ''); - } - - return @collect; - - sub header { #17 lines - my ( $page, $tot_pages, $date, $invnum, @address ) = @_ ; - push @address, '', '', '', ''; - - my @return = (); - my $i = ' 'x32; - push @return, - '', - $i. 'Invoice', - $i. substr("Page $page of $tot_pages".' 'x10, 0, 20). - time2str("%x", $date ). " FS-". $invnum, - '', - '', - $add1, - $add2, - $add3, - $add4, - '', - splice @address, 0, 7; - ; - return map $_. "\n", @return; - } - - sub myswrite { - my $format = <, L, L, L, -L, schema.html from the base documentation. - -=head1 HISTORY - -ivan@voicenet.com 97-jul-1 - -small fix for new API ivan@sisd.com 98-mar-14 - -charges can be negative ivan@sisd.com 98-jul-13 - -pod, ingegrate with FS::Invoice ivan@sisd.com 98-sep-20 - -$Log: cust_bill.pm,v $ -Revision 1.7 1999-02-09 09:55:05 ivan -invoices show line items for each service in a package (see the label method -of FS::cust_svc) - -Revision 1.6 1999/01/25 12:26:07 ivan -yet more mod_perl stuff - -Revision 1.5 1999/01/18 21:58:03 ivan -esthetic: eq and ne were used in a few places instead of == and != - -Revision 1.4 1998/12/29 11:59:36 ivan -mostly properly OO, some work still to be done with svc_ stuff - -Revision 1.3 1998/11/13 09:56:53 ivan -change configuration file layout to support multiple distinct databases (with -own set of config files, export, etc.) - -Revision 1.2 1998/11/07 10:24:24 ivan -don't use depriciated FS::Bill and FS::Invoice, other miscellania - - -=cut - -1; - diff --git a/site_perl/cust_bill_pkg.pm b/site_perl/cust_bill_pkg.pm deleted file mode 100644 index a52539433..000000000 --- a/site_perl/cust_bill_pkg.pm +++ /dev/null @@ -1,150 +0,0 @@ -package FS::cust_bill_pkg; - -use strict; -use vars qw( @ISA ); -use FS::Record qw( qsearchs ); -use FS::cust_pkg; -use FS::cust_bill; - -@ISA = qw(FS::Record ); - -=head1 NAME - -FS::cust_bill_pkg - Object methods for cust_bill_pkg records - -=head1 SYNOPSIS - - use FS::cust_bill_pkg; - - $record = new FS::cust_bill_pkg \%hash; - $record = new FS::cust_bill_pkg { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::cust_bill_pkg object represents an invoice line item. -FS::cust_bill_pkg inherits from FS::Record. The following fields are currently -supported: - -=over 4 - -=item invnum - invoice (see L) - -=item pkgnum - package (see L) - -=item setup - setup fee - -=item recur - recurring fee - -=item sdate - starting date of recurring fee - -=item edate - ending date of recurring fee - -=back - -sdate and edate are specified as UNIX timestamps; see L. Also -see L and L for conversion functions. - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new line item. To add the line item to the database, see -L<"insert">. Line items are normally created by calling the bill method of a -customer object (see L). - -=cut - -sub table { 'cust_bill_pkg'; } - -=item insert - -Adds this line item to the database. If there is an error, returns the error, -otherwise returns false. - -=item delete - -Currently unimplemented. I don't remove line items because there would then be -no record the items ever existed (which is bad, no?) - -=cut - -sub delete { - return "Can't delete cust_bill_pkg records!"; -} - -=item replace OLD_RECORD - -Currently unimplemented. This would be even more of an accounting nightmare -than deleteing the items. Just don't do it. - -=cut - -sub replace { - return "Can't modify cust_bill_pkg records!"; -} - -=item check - -Checks all fields to make sure this is a valid line item. If there is an -error, returns the error, otherwise returns false. Called by the insert -method. - -=cut - -sub check { - my $self = shift; - - my $error = - $self->ut_number('pkgnum') - || $self->ut_number('invnum') - || $self->ut_money('setup') - || $self->ut_money('recur') - || $self->ut_numbern('sdate') - || $self->ut_numbern('edate') - ; - return $error if $error; - - if ( $self->pkgnum != 0 ) { #allow unchecked pkgnum 0 for tax! (add to part_pkg?) - return "Unknown pkgnum ". $self->pkgnum - unless qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } ); - } - - return "Unknown invnum" - unless qsearchs( 'cust_bill' ,{ 'invnum' => $self->invnum } ); - - ''; #no error -} - -=back - -=head1 VERSION - -$Id: cust_bill_pkg.pm,v 1.2 1998-12-29 11:59:37 ivan Exp $ - -=head1 BUGS - -=head1 SEE ALSO - -L, L, L, L, schema.html -from the base documentation. - -=head1 HISTORY - -ivan@sisd.com 98-mar-13 - -pod ivan@sisd.com 98-sep-21 - -=cut - -1; - diff --git a/site_perl/cust_credit.pm b/site_perl/cust_credit.pm deleted file mode 100644 index b9a05832b..000000000 --- a/site_perl/cust_credit.pm +++ /dev/null @@ -1,191 +0,0 @@ -package FS::cust_credit; - -use strict; -use vars qw( @ISA ); -use FS::UID qw( getotaker ); -use FS::Record qw( qsearchs ); -use FS::cust_main; - -@ISA = qw( FS::Record ); - -=head1 NAME - -FS::cust_credit - Object methods for cust_credit records - -=head1 SYNOPSIS - - use FS::cust_credit; - - $record = new FS::cust_credit \%hash; - $record = new FS::cust_credit { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::cust_credit object represents a credit. FS::cust_credit inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item crednum - primary key (assigned automatically for new credits) - -=item custnum - customer (see L) - -=item amount - amount of the credit - -=item credited - how much of this credit that is still outstanding, which is -amount minus all refunds (see L). - -=item _date - specified as a UNIX timestamp; see L. Also see -L and L for conversion functions. - -=item otaker - order taker (assigned automatically, see L) - -=item reason - text - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new credit. To add the credit to the database, see L<"insert">. - -=cut - -sub table { 'cust_credit'; } - -=item insert - -Adds this credit to the database ("Posts" the credit). If there is an error, -returns the error, otherwise returns false. - -When adding new invoices, credited must be amount (or null, in which case it is -automatically set to amount). - -=cut - -sub insert { - my $self = shift; - - my $error; - return $error if $error = $self->ut_money('credited') - || $self->ut_money('amount'); - - $self->credited($self->amount) if $self->credited == 0 - || $self->credited eq ''; - return "credited != amount!" - unless $self->credited == $self->amount; - - $self->SUPER::insert; -} - -=item delete - -Currently unimplemented. - -=cut - -sub delete { - return "Can't remove credit!" -} - -=item replace OLD_RECORD - -Replaces the OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -Only credited may be changed. Credited is normally updated by creating and -inserting a refund (see L). - -=cut - -sub replace { - my ( $new, $old ) = ( shift, shift ); - - return "Can't change custnum!" unless $old->custnum == $new->custnum; - #return "Can't change date!" unless $old->_date eq $new->_date; - return "Can't change date!" unless $old->_date == $new->_date; - return "Can't change amount!" unless $old->amount == $new->amount; - return "(New) credited can't be > (new) amount!" - if $new->credited > $new->amount; - - $new->SUPER::replace($old); -} - -=item check - -Checks all fields to make sure this is a valid credit. If there is an error, -returns the error, otherwise returns false. Called by the insert and replace -methods. - -=cut - -sub check { - my $self = shift; - - my $error = - $self->ut_numbern('crednum') - || $self->ut_number('custnum') - || $self->ut_numbern('_date') - || $self->ut_money('amount') - || $self->ut_money('credited') - || $self->ut_textn('reason'); - ; - return $error if $error; - - return "Unknown customer" - unless qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); - - $self->_date(time) unless $self->_date; - - $self->otaker(getotaker); - - ''; #no error -} - -=back - -=head1 VERSION - -$Id: cust_credit.pm,v 1.4 1999-01-25 12:26:08 ivan Exp $ - -=head1 BUGS - -The delete method. - -=head1 SEE ALSO - -L, L, L, schema.html from the base -documentation. - -=head1 HISTORY - -ivan@sisd.com 98-mar-17 - -pod, otaker from FS::UID ivan@sisd.com 98-sep-21 - -$Log: cust_credit.pm,v $ -Revision 1.4 1999-01-25 12:26:08 ivan -yet more mod_perl stuff - -Revision 1.3 1999/01/18 21:58:04 ivan -esthetic: eq and ne were used in a few places instead of == and != - -Revision 1.2 1998/12/29 11:59:38 ivan -mostly properly OO, some work still to be done with svc_ stuff - - -=cut - -1; - diff --git a/site_perl/cust_main.pm b/site_perl/cust_main.pm deleted file mode 100644 index 6140dcc29..000000000 --- a/site_perl/cust_main.pm +++ /dev/null @@ -1,1070 +0,0 @@ -#this is so kludgy i'd be embarassed if it wasn't cybercash's fault -package main; -use vars qw($paymentserversecret $paymentserverport $paymentserverhost); - -package FS::cust_main; - -use strict; -use vars qw( @ISA $conf $lpr $processor $xaction $E_NoErr $invoice_from - $smtpmachine ); -use Safe; -use Carp; -use Time::Local; -use Date::Format; -use Date::Manip; -use Mail::Internet; -use Mail::Header; -use Business::CreditCard; -use FS::UID qw( getotaker ); -use FS::Record qw( qsearchs qsearch ); -use FS::cust_pkg; -use FS::cust_bill; -use FS::cust_bill_pkg; -use FS::cust_pay; -use FS::cust_credit; -use FS::cust_pay_batch; -use FS::part_referral; -use FS::cust_main_county; -use FS::agent; -use FS::cust_main_invoice; - -@ISA = qw( FS::Record ); - -#ask FS::UID to run this stuff for us later -$FS::UID::callback{'FS::cust_main'} = sub { - $conf = new FS::Conf; - $lpr = $conf->config('lpr'); - $invoice_from = $conf->config('invoice_from'); - $smtpmachine = $conf->config('smtpmachine'); - - if ( $conf->exists('cybercash3.2') ) { - require CCMckLib3_2; - #qw($MCKversion %Config InitConfig CCError CCDebug CCDebug2); - require CCMckDirectLib3_2; - #qw(SendCC2_1Server); - require CCMckErrno3_2; - #qw(MCKGetErrorMessage $E_NoErr); - import CCMckErrno3_2 qw($E_NoErr); - - my $merchant_conf; - ($merchant_conf,$xaction)= $conf->config('cybercash3.2'); - my $status = &CCMckLib3_2::InitConfig($merchant_conf); - if ( $status != $E_NoErr ) { - warn "CCMckLib3_2::InitConfig error:\n"; - foreach my $key (keys %CCMckLib3_2::Config) { - warn " $key => $CCMckLib3_2::Config{$key}\n" - } - my($errmsg) = &CCMckErrno3_2::MCKGetErrorMessage($status); - die "CCMckLib3_2::InitConfig fatal error: $errmsg\n"; - } - $processor='cybercash3.2'; - } elsif ( $conf->exists('cybercash2') ) { - require CCLib; - #qw(sendmserver); - ( $main::paymentserverhost, - $main::paymentserverport, - $main::paymentserversecret, - $xaction, - ) = $conf->config('cybercash2'); - $processor='cybercash2'; - } -}; - -=head1 NAME - -FS::cust_main - Object methods for cust_main records - -=head1 SYNOPSIS - - use FS::cust_main; - - $record = new FS::cust_main \%hash; - $record = new FS::cust_main { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - - @cust_pkg = $record->all_pkgs; - - @cust_pkg = $record->ncancelled_pkgs; - - $error = $record->bill; - $error = $record->bill %options; - $error = $record->bill 'time' => $time; - - $error = $record->collect; - $error = $record->collect %options; - $error = $record->collect 'invoice_time' => $time, - 'batch_card' => 'yes', - 'report_badcard' => 'yes', - ; - -=head1 DESCRIPTION - -An FS::cust_main object represents a customer. FS::cust_main inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item custnum - primary key (assigned automatically for new customers) - -=item agentnum - agent (see L) - -=item refnum - referral (see L) - -=item first - name - -=item last - name - -=item ss - social security number (optional) - -=item company - (optional) - -=item address1 - -=item address2 - (optional) - -=item city - -=item county - (optional, see L) - -=item state - (see L) - -=item zip - -=item country - (see L) - -=item daytime - phone (optional) - -=item night - phone (optional) - -=item fax - phone (optional) - -=item payby - `CARD' (credit cards), `BILL' (billing), or `COMP' (free) - -=item payinfo - card number, P.O.#, or comp issuer (4-8 lowercase alphanumerics; think username) - -=item paydate - expiration date, mm/yyyy, m/yyyy, mm/yy or m/yy - -=item payname - name on card or billing name - -=item tax - tax exempt, empty or `Y' - -=item otaker - order taker (assigned automatically, see L) - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new customer. To add the customer to the database, see L<"insert">. - -Note that this stores the 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 table { 'cust_main'; } - -=item insert - -Adds this customer to the database. If there is an error, returns the error, -otherwise returns false. - -=item delete NEW_CUSTNUM - -This deletes the customer. If there is an error, returns the error, otherwise -returns false. - -This will completely remove all traces of the customer record. This is not -what you want when a customer cancels service; for that, cancel all of the -customer's packages (see L). - -If the customer has any packages, you need to pass a new (valid) customer -number for those packages to be transferred to. - -You can't delete a customer with invoices (see L), -or credits (see L). - -=cut - -sub delete { - my $self = shift; - - if ( qsearch( 'cust_bill', { 'custnum' => $self->custnum } ) ) { - return "Can't delete a customer with invoices"; - } - if ( qsearch( 'cust_credit', { 'custnum' => $self->custnum } ) ) { - return "Can't delete a customer with credits"; - } - - 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 @cust_pkg = qsearch( 'cust_pkg', { 'custnum' => $self->custnum } ); - if ( @cust_pkg ) { - my $new_custnum = shift; - return "Invalid new customer number: $new_custnum" - unless qsearchs( 'cust_main', { 'custnum' => $new_custnum } ); - foreach my $cust_pkg ( @cust_pkg ) { - my %hash = $cust_pkg->hash; - $hash{'custnum'} = $new_custnum; - my $new_cust_pkg = new FS::cust_pkg ( \%hash ); - my $error = $new_cust_pkg->replace($cust_pkg); - return $error if $error; - } - } - foreach my $cust_main_invoice ( - qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } ) - ) { - my $error = $cust_main_invoice->delete; - return $error if $error; - } - - $self->SUPER::delete; -} - -=item replace OLD_RECORD - -Replaces the OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -=item check - -Checks all fields to make sure this is a valid customer record. If there is -an error, returns the error, otherwise returns false. Called by the insert -and repalce methods. - -=cut - -sub check { - my $self = shift; - - my $error = - $self->ut_numbern('custnum') - || $self->ut_number('agentnum') - || $self->ut_number('refnum') - || $self->ut_textn('company') - || $self->ut_text('address1') - || $self->ut_textn('address2') - || $self->ut_text('city') - || $self->ut_textn('county') - || $self->ut_textn('state') - || $self->ut_phonen('daytime') - || $self->ut_phonen('night') - || $self->ut_phonen('fax') - ; - return $error if $error; - - return "Unknown agent" - unless qsearchs( 'agent', { 'agentnum' => $self->agentnum } ); - - return "Unknown referral" - unless qsearchs( 'part_referral', { 'refnum' => $self->refnum } ); - - $self->getfield('last') =~ /^([\w \,\.\-\']+)$/ - or return "Illegal last name: ". $self->getfield('last'); - $self->setfield('last',$1); - - $self->first =~ /^([\w \,\.\-\']+)$/ - or return "Illegal first name: ". $self->first; - $self->first($1); - - if ( $self->ss eq '' ) { - $self->ss(''); - } else { - my $ss = $self->ss; - $ss =~ s/\D//g; - $ss =~ /^(\d{3})(\d{2})(\d{4})$/ - or return "Illegal social security number: ". $self->ss; - $self->ss("$1-$2-$3"); - } - - $self->country =~ /^(\w\w)$/ or return "Illegal country: ". $self->country; - $self->country($1); - unless ( qsearchs('cust_main_county', { - 'country' => $self->country, - 'state' => '', - } ) ) { - return "Unknown state/county/country: ". - $self->state. "/". $self->county. "/". $self->country - unless qsearchs('cust_main_county',{ - 'state' => $self->state, - 'county' => $self->county, - 'country' => $self->country, - } ); - } - - $self->zip =~ /^\s*(\w[\w\-\s]{3,8}\w)\s*$/ - or return "Illegal zip: ". $self->zip; - $self->zip($1); - - $self->payby =~ /^(CARD|BILL|COMP)$/ - or return "Illegal payby: ". $self->payby; - $self->payby($1); - - if ( $self->payby eq 'CARD' ) { - - my $payinfo = $self->payinfo; - $payinfo =~ s/\D//g; - $payinfo =~ /^(\d{13,16})$/ - or return "Illegal credit card number: ". $self->payinfo; - $payinfo = $1; - $self->payinfo($payinfo); - validate($payinfo) - or return "Illegal credit card number: ". $self->payinfo; - return "Unknown card type" if cardtype($self->payinfo) eq "Unknown"; - - } elsif ( $self->payby eq 'BILL' ) { - - $error = $self->ut_textn('payinfo'); - return "Illegal P.O. number: ". $self->payinfo if $error; - - } elsif ( $self->payby eq 'COMP' ) { - - $error = $self->ut_textn('payinfo'); - return "Illegal comp account issuer: ". $self->payinfo if $error; - - } - - if ( $self->paydate eq '' ) { - return "Expriation date required" unless $self->payby eq 'BILL'; - $self->paydate(''); - } else { - $self->paydate =~ /^(\d{1,2})[\/\-](\d{2}(\d{2})?)$/ - or return "Illegal expiration date: ". $self->paydate; - if ( length($2) == 4 ) { - $self->paydate("$2-$1-01"); - } elsif ( $2 > 97 ) { #should pry change to check for "this year" - $self->paydate("19$2-$1-01"); - } else { - $self->paydate("20$2-$1-01"); - } - } - - if ( $self->payname eq '' ) { - $self->payname( $self->first. " ". $self->getfield('last') ); - } else { - $self->payname =~ /^([\w \,\.\-\']+)$/ - or return "Illegal billing name: ". $self->payname; - $self->payname($1); - } - - $self->tax =~ /^(Y?)$/ or return "Illegal tax: ". $self->tax; - $self->tax($1); - - $self->otaker(getotaker); - - ''; #no error -} - -=item all_pkgs - -Returns all packages (see L) for this customer. - -=cut - -sub all_pkgs { - my $self = shift; - qsearch( 'cust_pkg', { 'custnum' => $self->custnum }); -} - -=item ncancelled_pkgs - -Returns all non-cancelled packages (see L) for this customer. - -=cut - -sub ncancelled_pkgs { - my $self = shift; - qsearch( 'cust_pkg', { - 'custnum' => $self->custnum, - 'cancel' => '', - }); -} - -=item bill OPTIONS - -Generates invoices (see L) for this customer. Usually used in -conjunction with the collect method. - -The only currently available option is `time', which bills the customer as if -it were that time. It is specified as a UNIX timestamp; see -L). Also see L and L for conversion -functions. - -If there is an error, returns the error, otherwise returns false. - -=cut - -sub bill { - my( $self, %options ) = @_; - my $time = $options{'time'} || time; - - my $error; - - #put below somehow? - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - local $SIG{PIPE} = 'IGNORE'; - - # find the packages which are due for billing, find out how much they are - # & generate invoice database. - - my( $total_setup, $total_recur ) = ( 0, 0 ); - my @cust_bill_pkg; - - foreach my $cust_pkg ( - qsearch('cust_pkg',{'custnum'=> $self->getfield('custnum') } ) - ) { - - next if $cust_pkg->getfield('cancel'); - - #? to avoid use of uninitialized value errors... ? - $cust_pkg->setfield('bill', '') - unless defined($cust_pkg->bill); - - my $part_pkg = qsearchs( 'part_pkg', { 'pkgpart' => $cust_pkg->pkgpart } ); - - #so we don't modify cust_pkg record unnecessarily - my $cust_pkg_mod_flag = 0; - my %hash = $cust_pkg->hash; - my $old_cust_pkg = new FS::cust_pkg \%hash; - - # bill setup - my $setup = 0; - unless ( $cust_pkg->setup ) { - my $setup_prog = $part_pkg->getfield('setup'); - my $cpt = new Safe; - #$cpt->permit(); #what is necessary? - $cpt->share(qw( $cust_pkg )); #can $cpt now use $cust_pkg methods? - $setup = $cpt->reval($setup_prog); - unless ( defined($setup) ) { - warn "Error reval-ing part_pkg->setup pkgpart ", - $part_pkg->pkgpart, ": $@"; - } else { - $cust_pkg->setfield('setup',$time); - $cust_pkg_mod_flag=1; - } - } - - #bill recurring fee - my $recur = 0; - my $sdate; - if ( $part_pkg->getfield('freq') > 0 && - ! $cust_pkg->getfield('susp') && - ( $cust_pkg->getfield('bill') || 0 ) < $time - ) { - my $recur_prog = $part_pkg->getfield('recur'); - my $cpt = new Safe; - #$cpt->permit(); #what is necessary? - $cpt->share(qw( $cust_pkg )); #can $cpt now use $cust_pkg methods? - $recur = $cpt->reval($recur_prog); - unless ( defined($recur) ) { - warn "Error reval-ing part_pkg->recur pkgpart ", - $part_pkg->pkgpart, ": $@"; - } else { - #change this bit to use Date::Manip? - #$sdate=$cust_pkg->bill || time; - #$sdate=$cust_pkg->bill || $time; - $sdate = $cust_pkg->bill || $cust_pkg->setup || $time; - my ($sec,$min,$hour,$mday,$mon,$year) = - (localtime($sdate) )[0,1,2,3,4,5]; - $mon += $part_pkg->getfield('freq'); - until ( $mon < 12 ) { $mon -= 12; $year++; } - $cust_pkg->setfield('bill', - timelocal($sec,$min,$hour,$mday,$mon,$year)); - $cust_pkg_mod_flag = 1; - } - } - - warn "setup is undefinded" unless defined($setup); - warn "recur is undefinded" unless defined($recur); - warn "cust_pkg bill is undefinded" unless defined($cust_pkg->bill); - - if ( $cust_pkg_mod_flag ) { - $error=$cust_pkg->replace($old_cust_pkg); - if ( $error ) { #just in case - warn "Error modifying pkgnum ", $cust_pkg->pkgnum, ": $error"; - } else { - $setup = sprintf( "%.2f", $setup ); - $recur = sprintf( "%.2f", $recur ); - my $cust_bill_pkg = new FS::cust_bill_pkg ({ - 'pkgnum' => $cust_pkg->pkgnum, - 'setup' => $setup, - 'recur' => $recur, - 'sdate' => $sdate, - 'edate' => $cust_pkg->bill, - }); - push @cust_bill_pkg, $cust_bill_pkg; - $total_setup += $setup; - $total_recur += $recur; - } - } - - } - - my $charged = sprintf( "%.2f", $total_setup + $total_recur ); - - return '' if scalar(@cust_bill_pkg) == 0; - - unless ( $self->getfield('tax') =~ /Y/i - || $self->getfield('payby') eq 'COMP' - ) { - my $cust_main_county = qsearchs('cust_main_county',{ - 'state' => $self->state, - 'county' => $self->county, - 'country' => $self->country, - } ); - my $tax = sprintf( "%.2f", - $charged * ( $cust_main_county->getfield('tax') / 100 ) - ); - $charged = sprintf( "%.2f", $charged+$tax ); - - my $cust_bill_pkg = new FS::cust_bill_pkg ({ - 'pkgnum' => 0, - 'setup' => $tax, - 'recur' => 0, - 'sdate' => '', - 'edate' => '', - }); - push @cust_bill_pkg, $cust_bill_pkg; - } - - my $cust_bill = new FS::cust_bill ( { - 'custnum' => $self->getfield('custnum'), - '_date' => $time, - 'charged' => $charged, - } ); - $error = $cust_bill->insert; - #shouldn't happen, but how else to handle this? (wrap me in eval, to catch - # fatal errors) - die "Error creating cust_bill record: $error!\n", - "Check updated but unbilled packages for customer", $self->custnum, "\n" - if $error; - - my $invnum = $cust_bill->invnum; - my $cust_bill_pkg; - foreach $cust_bill_pkg ( @cust_bill_pkg ) { - $cust_bill_pkg->setfield( 'invnum', $invnum ); - $error = $cust_bill_pkg->insert; - #shouldn't happen, but how else tohandle this? - die "Error creating cust_bill_pkg record: $error!\n", - "Check incomplete invoice ", $invnum, "\n" - if $error; - } - - ''; #no error -} - -=item collect OPTIONS - -(Attempt to) collect money for this customer's outstanding invoices (see -L). Usually used after the bill method. - -Depending on the value of `payby', this may print an invoice (`BILL'), charge -a credit card (`CARD'), or just add any necessary (pseudo-)payment (`COMP'). - -If there is an error, returns the error, otherwise returns false. - -Currently available options are: - -invoice_time - Use this time when deciding when to print invoices and -late notices on those invoices. The default is now. It is specified as a UNIX timestamp; see L). Also see L and L -for conversion functions. - -batch_card - Set this true to batch cards (see L). By -default, cards are processed immediately, which will generate an error if -CyberCash is not installed. - -report_badcard - Set this true if you want bad card transactions to -return an error. By default, they don't. - -=cut - -sub collect { - my( $self, %options ) = @_; - my $invoice_time = $options{'invoice_time'} || time; - - my $total_owed = $self->balance; - return '' unless $total_owed > 0; #redundant????? - - #put below somehow? - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - local $SIG{PIPE} = 'IGNORE'; - - foreach my $cust_bill ( - qsearch('cust_bill', { 'custnum' => $self->custnum, } ) - ) { - - #this has to be before next's - my $amount = sprintf( "%.2f", $total_owed < $cust_bill->owed - ? $total_owed - : $cust_bill->owed - ); - $total_owed = sprintf( "%.2f", $total_owed - $amount ); - - next unless $cust_bill->owed > 0; - - next if qsearchs( 'cust_pay_batch', { 'invnum' => $cust_bill->invnum } ); - - #warn "invnum ". $cust_bill->invnum. " (owed ". $cust_bill->owed. ", amount $amount, total_owed $total_owed)"; - - next unless $amount > 0; - - if ( $self->payby eq 'BILL' ) { - - #30 days 2592000 - my $since = $invoice_time - ( $cust_bill->_date || 0 ); - #warn "$invoice_time ", $cust_bill->_date, " $since"; - if ( $since >= 0 #don't print future invoices - && ( $cust_bill->printed * 2592000 ) <= $since - ) { - - #my @print_text = $cust_bill->print_text; #( date ) - my @invoicing_list = $self->invoicing_list; - if ( grep { $_ ne 'POST' } @invoicing_list ) { #email invoice - $ENV{SMTPHOSTS} = $smtpmachine; - $ENV{MAILADDRESS} = $invoice_from; - my $header = new Mail::Header ( [ - "From: $invoice_from", - "To: ". join(', ', grep { $_ ne 'POST' } @invoicing_list ), - "Sender: $invoice_from", - "Reply-To: $invoice_from", - "Date: ". time2str("%a, %d %b %Y %X %z", time), - "Subject: Invoice", - ] ); - my $message = new Mail::Internet ( - 'Header' => $header, - 'Body' => [ $cust_bill->print_text ], #( date) - ); - $message->smtpsend or die "Can't send invoice email!"; #die? warn? - - } elsif ( ! @invoicing_list || grep { $_ eq 'POST' } @invoicing_list ) { - open(LPR, "|$lpr") or die "Can't open pipe to $lpr: $!"; - print LPR $cust_bill->print_text; #( date ) - close LPR - or die $! ? "Error closing $lpr: $!" - : "Exit status $? from $lpr"; - } - - my %hash = $cust_bill->hash; - $hash{'printed'}++; - my $new_cust_bill = new FS::cust_bill(\%hash); - my $error = $new_cust_bill->replace($cust_bill); - warn "Error updating $cust_bill->printed: $error" if $error; - - } - - } elsif ( $self->payby eq 'COMP' ) { - my $cust_pay = new FS::cust_pay ( { - 'invnum' => $cust_bill->invnum, - 'paid' => $amount, - '_date' => '', - 'payby' => 'COMP', - 'payinfo' => $self->payinfo, - 'paybatch' => '' - } ); - my $error = $cust_pay->insert; - return 'Error COMPing invnum #' . $cust_bill->invnum . - ':' . $error if $error; - - } elsif ( $self->payby eq 'CARD' ) { - - if ( $options{'batch_card'} ne 'yes' ) { - - return "Real time card processing not enabled!" unless $processor; - - if ( $processor =~ /^cybercash/ ) { - - #fix exp. date for cybercash - #$self->paydate =~ /^(\d+)\/\d*(\d{2})$/; - $self->paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/; - my $exp = "$2/$1"; - - my $paybatch = $cust_bill->invnum. - '-' . time2str("%y%m%d%H%M%S", time); - - my $payname = $self->payname || - $self->getfield('first'). ' '. $self->getfield('last'); - - my $address = $self->address1; - $address .= ", ". $self->address2 if $self->address2; - - my $country = 'USA' if $self->country eq 'US'; - - my @full_xaction = ( $xaction, - 'Order-ID' => $paybatch, - 'Amount' => "usd $amount", - 'Card-Number' => $self->getfield('payinfo'), - 'Card-Name' => $payname, - 'Card-Address' => $address, - 'Card-City' => $self->getfield('city'), - 'Card-State' => $self->getfield('state'), - 'Card-Zip' => $self->getfield('zip'), - 'Card-Country' => $country, - 'Card-Exp' => $exp, - ); - - my %result; - if ( $processor eq 'cybercash2' ) { - $^W=0; #CCLib isn't -w safe, ugh! - %result = &CCLib::sendmserver(@full_xaction); - $^W=1; - } elsif ( $processor eq 'cybercash3.2' ) { - %result = &CCMckDirectLib3_2::SendCC2_1Server(@full_xaction); - } else { - return "Unkonwn real-time processor $processor\n"; - } - - #if ( $result{'MActionCode'} == 7 ) { #cybercash smps v.1.1.3 - #if ( $result{'action-code'} == 7 ) { #cybercash smps v.2.1 - if ( $result{'MStatus'} eq 'success' ) { #cybercash smps v.2 or 3 - my $cust_pay = new FS::cust_pay ( { - 'invnum' => $cust_bill->invnum, - 'paid' => $amount, - '_date' => '', - 'payby' => 'CARD', - 'payinfo' => $self->payinfo, - 'paybatch' => "$processor:$paybatch", - } ); - my $error = $cust_pay->insert; - return 'Error applying payment, invnum #' . - $cust_bill->invnum. ':'. $error if $error; - } elsif ( $result{'Mstatus'} ne 'failure-bad-money' - || $options{'report_badcard'} ) { - return 'Cybercash error, invnum #' . - $cust_bill->invnum. ':'. $result{'MErrMsg'}; - } else { - return ''; - } - - } else { - return "Unkonwn real-time processor $processor\n"; - } - - } else { #batch card - - my $cust_pay_batch = new FS::cust_pay_batch ( { - 'invnum' => $cust_bill->getfield('invnum'), - 'custnum' => $self->getfield('custnum'), - 'last' => $self->getfield('last'), - 'first' => $self->getfield('first'), - 'address1' => $self->getfield('address1'), - 'address2' => $self->getfield('address2'), - 'city' => $self->getfield('city'), - 'state' => $self->getfield('state'), - 'zip' => $self->getfield('zip'), - 'country' => $self->getfield('country'), - 'trancode' => 77, - 'cardnum' => $self->getfield('payinfo'), - 'exp' => $self->getfield('paydate'), - 'payname' => $self->getfield('payname'), - 'amount' => $amount, - } ); - my $error = $cust_pay_batch->insert; - return "Error adding to cust_pay_batch: $error" if $error; - - } - - } else { - return "Unknown payment type ". $self->payby; - } - - - - - - } - ''; - -} - -=item total_owed - -Returns the total owed for this customer on all invoices -(see L). - -=cut - -sub total_owed { - my $self = shift; - my $total_bill = 0; - foreach my $cust_bill ( qsearch('cust_bill', { - 'custnum' => $self->custnum, - } ) ) { - $total_bill += $cust_bill->owed; - } - sprintf( "%.2f", $total_bill ); -} - -=item total_credited - -Returns the total credits (see L) for this customer. - -=cut - -sub total_credited { - my $self = shift; - my $total_credit = 0; - foreach my $cust_credit ( qsearch('cust_credit', { - 'custnum' => $self->custnum, - } ) ) { - $total_credit += $cust_credit->credited; - } - sprintf( "%.2f", $total_credit ); -} - -=item balance - -Returns the balance for this customer (total owed minus total credited). - -=cut - -sub balance { - my $self = shift; - sprintf( "%.2f", $self->total_owed - $self->total_credited ); -} - -=item invoicing_list [ ARRAYREF ] - -If an arguement is given, sets these email addresses as invoice recipients -(see L). Errors are not fatal and are not reported -(except as warnings), so use check_invoicing_list first. - -Returns a list of email addresses (with svcnum entries expanded). - -Note: You can clear the invoicing list by passing an empty ARRAYREF. You can -check it without disturbing anything by passing nothing. - -This interface may change in the future. - -=cut - -sub invoicing_list { - my( $self, $arrayref ) = @_; - if ( $arrayref ) { - my @cust_main_invoice; - if ( $self->custnum ) { - @cust_main_invoice = - qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } ); - } else { - @cust_main_invoice = (); - } - foreach my $cust_main_invoice ( @cust_main_invoice ) { - #warn $cust_main_invoice->destnum; - unless ( grep { $cust_main_invoice->address eq $_ } @{$arrayref} ) { - #warn $cust_main_invoice->destnum; - my $error = $cust_main_invoice->delete; - warn $error if $error; - } - } - if ( $self->custnum ) { - @cust_main_invoice = - qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } ); - } else { - @cust_main_invoice = (); - } - foreach my $address ( @{$arrayref} ) { - unless ( grep { $address eq $_->address } @cust_main_invoice ) { - my $cust_main_invoice = new FS::cust_main_invoice ( { - 'custnum' => $self->custnum, - 'dest' => $address, - } ); - my $error = $cust_main_invoice->insert; - warn $error if $error; - } - } - } - if ( $self->custnum ) { - map { $_->address } - qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } ); - } else { - (); - } -} - -=item check_invoicing_list ARRAYREF - -Checks these arguements as valid input for the invoicing_list method. If there -is an error, returns the error, otherwise returns false. - -=cut - -sub check_invoicing_list { - my( $self, $arrayref ) = @_; - foreach my $address ( @{$arrayref} ) { - my $cust_main_invoice = new FS::cust_main_invoice ( { - 'custnum' => $self->custnum, - 'dest' => $address, - } ); - my $error = $self->custnum - ? $cust_main_invoice->check - : $cust_main_invoice->checkdest - ; - return $error if $error; - } - ''; -} - -=back - -=head1 VERSION - -$Id: cust_main.pm,v 1.24 1999-07-20 10:37:05 ivan Exp $ - -=head1 BUGS - -The delete method. - -The delete method should possibly take an FS::cust_main object reference -instead of a scalar customer number. - -Bill and collect options should probably be passed as references instead of a -list. - -CyberCash v2 forces us to define some variables in package main. - -There should probably be a configuration file with a list of allowed credit -card types. - -CyberCash is the only processor. - -No multiple currency support (probably a larger project than just this module). - -=head1 SEE ALSO - -L, L, L, L -L, L, L, -L, L, -L, schema.html from the base documentation. - -=head1 HISTORY - -ivan@voicenet.com 97-jul-28 - -Changed to standard Business::CreditCard -no more TableUtil -EXPORT_OK FS::Record's hfields -removed unique calls and locking (not needed here now) -wrapped the (now) optional fields in if statements in sub check (notyetdone!) -ivan@sisd.com 97-nov-12 - -updated paydate with SQL-type date info ivan@sisd.com 98-mar-5 - -Added export of datasrc from UID.pm for Pg6.3 -changed 'day' to 'daytime' because Pg6.3 reserves the day word - bmccane@maxbaud.net 98-apr-3 - -in ->create, s/svc_acct/cust_main/, now it should actually eliminate the -warnings it was meant to ivan@sisd.com 98-jul-16 - -don't require a phone number and allow '/' in company names -ivan@sisd.com 98-jul-18 - -use ut_ and rewrite &check, &*_pkgs ivan@sisd.com 98-sep-5 - -pod, merge with FS::Bill (about time!), total_owed, total_credited and balance -methods, cleaned collect method, source modifications no longer necessary to -enable cybercash, cybercash v3 support, don't need to import -FS::UID::{datasrc,checkruid} ivan@sisd.com 98-sep-19-21 - -$Log: cust_main.pm,v $ -Revision 1.24 1999-07-20 10:37:05 ivan -cleaned up the new one-screen signup bits in htdocs/edit/cust_main.cgi to -prepare for a signup server - -Revision 1.23 1999/07/17 02:24:14 ivan -bug noticed by Steve Gertz - -Revision 1.22 1999/04/15 16:44:36 ivan -delete customers - -Revision 1.21 1999/04/14 07:47:53 ivan -i18n fixes - -Revision 1.20 1999/04/10 08:35:14 ivan -say what the unknown state/county/country are! - -Revision 1.19 1999/04/10 07:38:06 ivan -_all_ check stuff with illegal data return the bad data too, to help debugging - -Revision 1.18 1999/04/10 06:54:11 ivan -ditto - -Revision 1.17 1999/04/10 05:27:38 ivan -display an illegal payby, to assist importing - -Revision 1.16 1999/04/07 14:32:19 ivan -more &invoicing_list logic to skip searches when there is no custnum - -Revision 1.15 1999/04/07 13:41:54 ivan -in &invoicing_list, don't search if there's no custnum yet - -Revision 1.14 1999/03/29 12:06:15 ivan -buglet in email invoices fixed - -Revision 1.13 1999/02/28 20:09:03 ivan -allow spaces in zip codes, for (at least) canada. pointed out by -Clayton Gray - -Revision 1.12 1999/02/27 21:24:22 ivan -parse paydate correctly for cybercash - -Revision 1.11 1999/02/23 08:09:27 ivan -beginnings of one-screen new customer entry and some other miscellania - -Revision 1.10 1999/01/25 12:26:09 ivan -yet more mod_perl stuff - -Revision 1.9 1999/01/18 09:22:41 ivan -changes to track email addresses for email invoicing - -Revision 1.8 1998/12/29 11:59:39 ivan -mostly properly OO, some work still to be done with svc_ stuff - -Revision 1.7 1998/12/16 09:58:52 ivan -library support for editing email invoice destinations (not in sub collect yet) - -Revision 1.6 1998/11/18 09:01:42 ivan -i18n! i18n! - -Revision 1.5 1998/11/15 11:23:14 ivan -use FS::table_name for all searches to eliminate warnings, -emit state/county when they don't match - -Revision 1.4 1998/11/15 05:30:48 ivan -bugfix for new config layout - -Revision 1.3 1998/11/13 09:56:54 ivan -change configuration file layout to support multiple distinct databases (with -own set of config files, export, etc.) - -Revision 1.2 1998/11/07 10:24:25 ivan -don't use depriciated FS::Bill and FS::Invoice, other miscellania - - -=cut - -1; - - diff --git a/site_perl/cust_main_county.pm b/site_perl/cust_main_county.pm deleted file mode 100644 index 1418ca1ea..000000000 --- a/site_perl/cust_main_county.pm +++ /dev/null @@ -1,132 +0,0 @@ -package FS::cust_main_county; - -use strict; -use vars qw( @ISA ); -use FS::Record; - -@ISA = qw( FS::Record ); - -=head1 NAME - -FS::cust_main_county - Object methods for cust_main_county objects - -=head1 SYNOPSIS - - use FS::cust_main_county; - - $record = new FS::cust_main_county \%hash; - $record = new FS::cust_main_county { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::cust_main_county object represents a tax rate, defined by locale. -FS::cust_main_county inherits from FS::Record. The following fields are -currently supported: - -=over 4 - -=item taxnum - primary key (assigned automatically for new tax rates) - -=item state - -=item county - -=item country - -=item tax - percentage - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new tax rate. To add the tax rate to the database, see L<"insert">. - -=cut - -sub table { 'cust_main_county'; } - -=item insert - -Adds this tax rate to the database. If there is an error, returns the error, -otherwise returns false. - -=item delete - -Deletes this tax rate from the database. If there is an error, returns the -error, otherwise returns false. - -=item replace OLD_RECORD - -Replaces the OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -=item check - -Checks all fields to make sure this is a valid tax rate. If there is an error, -returns the error, otherwise returns false. Called by the insert and replace -methods. - -=cut - -sub check { - my $self = shift; - - $self->ut_numbern('taxnum') - || $self->ut_textn('state') - || $self->ut_textn('county') - || $self->ut_text('country') - || $self->ut_float('tax') - ; - -} - -=back - -=head1 VERSION - -$Id: cust_main_county.pm,v 1.4 1999-07-20 10:37:05 ivan Exp $ - -=head1 BUGS - -=head1 SEE ALSO - -L, L, L, schema.html from the base -documentation. - -=head1 HISTORY - -ivan@voicenet.com 97-dec-16 - -Changed check for 'tax' to use the new ut_float subroutine - bmccane@maxbaud.net 98-apr-3 - -pod ivan@sisd.com 98-sep-21 - -$Log: cust_main_county.pm,v $ -Revision 1.4 1999-07-20 10:37:05 ivan -cleaned up the new one-screen signup bits in htdocs/edit/cust_main.cgi to -prepare for a signup server - -Revision 1.3 1998/12/29 11:59:41 ivan -mostly properly OO, some work still to be done with svc_ stuff - -Revision 1.2 1998/11/18 09:01:43 ivan -i18n! i18n! - - -=cut - -1; - diff --git a/site_perl/cust_main_invoice.pm b/site_perl/cust_main_invoice.pm deleted file mode 100644 index 2823294c1..000000000 --- a/site_perl/cust_main_invoice.pm +++ /dev/null @@ -1,214 +0,0 @@ -package FS::cust_main_invoice; - -use strict; -use vars qw(@ISA $conf $mydomain); -use Exporter; -use FS::Record qw( qsearchs ); -use FS::Conf; -use FS::cust_main; -use FS::svc_acct; - -@ISA = qw( FS::Record ); - -#ask FS::UID to run this stuff for us later -$FS::UID::callback{'FS::cust_main_invoice'} = sub { - $conf = new FS::Conf; - $mydomain = $conf->config('domain'); -}; - -=head1 NAME - -FS::cust_main_invoice - Object methods for cust_main_invoice records - -=head1 SYNOPSIS - - use FS::cust_main_invoice; - - $record = new FS::cust_main_invoice \%hash; - $record = new FS::cust_main_invoice { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - - $email_address = $record->address; - -=head1 DESCRIPTION - -An FS::cust_main_invoice object represents an invoice destination. FS::cust_main_invoice inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item destnum - primary key - -=item custnum - customer (see L) - -=item dest - Invoice destination: If numeric, a svcnum, if string, a literal email address, or `POST' to enable mailing (the default if no cust_main_invoice records exist) - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new invoice destination. To add the invoice destination to the database, see L<"insert">. - -Note that this stores the 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 table { 'cust_main_invoice'; } - -=item insert - -Adds this record to the database. If there is an error, returns the error, -otherwise returns false. - -=item delete - -Delete this record from the database. - -=item replace OLD_RECORD - -Replaces the OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -=cut - -sub replace { - my ( $new, $old ) = ( shift, shift ); - - return "Can't change custnum!" unless $old->custnum == $new->custnum; - - $new->SUPER::replace; -} - - -=item check - -Checks all fields to make sure this is a valid invoice destination. If there is -an error, returns the error, otherwise returns false. Called by the insert -and repalce methods. - -=cut - -sub check { - my $self = shift; - - my $error = $self->ut_numbern('destnum') - || $self->ut_number('custnum') - || $self->checkdest; - ; - return $error if $error; - - return "Unknown customer" - unless qsearchs('cust_main',{ 'custnum' => $self->custnum }); - - ''; #noerror -} - -=item checkdest - -Checks the dest field only. - -=cut - -sub checkdest { - my $self = shift; - - my $error = $self->ut_text('dest'); - return $error if $error; - - if ( $self->dest eq 'POST' ) { - #contemplate our navel - } elsif ( $self->dest =~ /^(\d+)$/ ) { - return "Unknown local account (specified by svcnum)" - unless qsearchs( 'svc_acct', { 'svcnum' => $self->dest } ); - } elsif ( $self->dest =~ /^([\w\.\-]+)\@(([\w\.\-]+\.)+\w+)$/ ) { - my($user, $domain) = ($1, $2); - if ( $domain eq $mydomain ) { - my $svc_acct = qsearchs( 'svc_acct', { 'username' => $user } ); - return "Unknown local account (specified literally)" unless $svc_acct; - $svc_acct->svcnum =~ /^(\d+)$/ or die "Non-numeric svcnum?!"; - $self->dest($1); - } - } else { - return "Illegal destination!"; - } - - ''; #no error -} - -=item address - -Returns the literal email address for this record (or `POST'). - -=cut - -sub address { - my $self = shift; - if ( $self->dest =~ /(\d+)$/ ) { - my $svc_acct = qsearchs( 'svc_acct', { 'svcnum' => $1 } ); - $svc_acct->username . '@' . $mydomain; - } else { - $self->dest; - } -} - -=back - -=head1 VERSION - -$Id: cust_main_invoice.pm,v 1.6 1999-01-25 12:26:10 ivan Exp $ - -=head1 BUGS - -=head1 SEE ALSO - -L, L - -=head1 HISTORY - -ivan@voicenet.com 97-jul-1 - -added hfields -ivan@sisd.com 97-nov-13 - -$Log: cust_main_invoice.pm,v $ -Revision 1.6 1999-01-25 12:26:10 ivan -yet more mod_perl stuff - -Revision 1.5 1999/01/18 21:58:05 ivan -esthetic: eq and ne were used in a few places instead of == and != - -Revision 1.4 1999/01/18 09:22:42 ivan -changes to track email addresses for email invoicing - -Revision 1.3 1998/12/29 11:59:42 ivan -mostly properly OO, some work still to be done with svc_ stuff - -Revision 1.2 1998/12/16 09:58:53 ivan -library support for editing email invoice destinations (not in sub collect yet) - -Revision 1.1 1998/12/16 07:40:02 ivan -new table - -Revision 1.3 1998/11/15 04:33:00 ivan -updates for newest versoin - -Revision 1.2 1998/11/15 03:48:49 ivan -update for current version - - -=cut - -1; - diff --git a/site_perl/cust_pay.pm b/site_perl/cust_pay.pm deleted file mode 100644 index 46addac01..000000000 --- a/site_perl/cust_pay.pm +++ /dev/null @@ -1,207 +0,0 @@ -package FS::cust_pay; - -use strict; -use vars qw( @ISA ); -use Business::CreditCard; -use FS::Record qw( qsearchs ); -use FS::cust_bill; - -@ISA = qw( FS::Record ); - -=head1 NAME - -FS::cust_pay - Object methods for cust_pay objects - -=head1 SYNOPSIS - - use FS::cust_pay; - - $record = new FS::cust_pay \%hash; - $record = new FS::cust_pay { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::cust_pay object represents a payment. FS::cust_pay inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item paynum - primary key (assigned automatically for new payments) - -=item invnum - Invoice (see L) - -=item paid - Amount of this payment - -=item _date - specified as a UNIX timestamp; see L. Also see -L and L for conversion functions. - -=item payby - `CARD' (credit cards), `BILL' (billing), or `COMP' (free) - -=item payinfo - card number, P.O.#, or comp issuer (4-8 lowercase alphanumerics; think username) - -=item paybatch - text field for tracking card processing - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new payment. To add the payment to the databse, see L<"insert">. - -=cut - -sub table { 'cust_pay'; } - -=item insert - -Adds this payment to the databse, and updates the invoice (see -L). - -=cut - -sub insert { - my $self = shift; - - my $error; - - $error = $self->check; - return $error if $error; - - my $old_cust_bill = qsearchs( 'cust_bill', { 'invnum' => $self->invnum } ); - return "Unknown invnum" unless $old_cust_bill; - my %hash = $old_cust_bill->hash; - $hash{'owed'} = sprintf("%.2f", $hash{owed} - $self->paid ); - my $new_cust_bill = new FS::cust_bill ( \%hash ); - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - local $SIG{PIPE} = 'IGNORE'; - - $error = $new_cust_bill->replace($old_cust_bill); - return "Error modifying cust_bill: $error" if $error; - - $self->SUPER::insert; -} - -=item delete - -Currently unimplemented (accounting reasons). - -=cut - -sub delete { - return "Can't (yet?) delete cust_pay records!"; -} - -=item replace OLD_RECORD - -Currently unimplemented (accounting reasons). - -=cut - -sub replace { - return "Can't (yet?) modify cust_pay records!"; -} - -=item check - -Checks all fields to make sure this is a valid payment. If there is an error, -returns the error, otherwise returns false. Called by the insert method. - -=cut - -sub check { - my $self = shift; - - my $error; - - $error = - $self->ut_numbern('paynum') - || $self->ut_number('invnum') - || $self->ut_money('paid') - || $self->ut_numbern('_date') - ; - return $error if $error; - - $self->_date(time) unless $self->_date; - - $self->payby =~ /^(CARD|BILL|COMP)$/ or return "Illegal payby"; - $self->payby($1); - - if ( $self->payby eq 'CARD' ) { - my $payinfo = $self->payinfo; - $payinfo =~ s/\D//g; - $self->payinfo($payinfo); - if ( $self->payinfo ) { - $self->payinfo =~ /^(\d{13,16})$/ - or return "Illegal (mistyped?) credit card number (payinfo)"; - $self->payinfo($1); - validate($self->payinfo) or return "Illegal credit card number"; - return "Unknown card type" if cardtype($self->payinfo) eq "Unknown"; - } else { - $self->payinfo('N/A'); - } - - } else { - $error = $self->ut_textn('payinfo'); - return $error if $error; - } - - $error = $self->ut_textn('paybatch'); - return $error if $error; - - ''; #no error - -} - -=back - -=head1 VERSION - -$Id: cust_pay.pm,v 1.4 1999-07-29 09:07:44 ivan Exp $ - -=head1 BUGS - -Delete and replace methods. - -=head1 SEE ALSO - -L, L, schema.html from the base documentation. - -=head1 HISTORY - -ivan@voicenet.com 97-jul-1 - 25 - 29 - -new api ivan@sisd.com 98-mar-13 - -pod ivan@sisd.com 98-sep-21 - -$Log: cust_pay.pm,v $ -Revision 1.4 1999-07-29 09:07:44 ivan -embarassing. - -Revision 1.3 1999/01/25 12:26:11 ivan -yet more mod_perl stuff - -Revision 1.2 1998/12/29 11:59:43 ivan -mostly properly OO, some work still to be done with svc_ stuff - - -=cut - -1; - diff --git a/site_perl/cust_pay_batch.pm b/site_perl/cust_pay_batch.pm deleted file mode 100644 index c7a0ccb9d..000000000 --- a/site_perl/cust_pay_batch.pm +++ /dev/null @@ -1,235 +0,0 @@ -package FS::cust_pay_batch; - -use strict; -use vars qw( @ISA ); -use FS::Record; -use Business::CreditCard; - -@ISA = qw( FS::Record ); - -=head1 NAME - -FS::cust_pay_batch - Object methods for batch cards - -=head1 SYNOPSIS - - use FS::cust_pay_batch; - - $record = new FS::cust_pay_batch \%hash; - $record = new FS::cust_pay_batch { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::cust_pay_batch object represents a credit card transaction ready to be -batched (sent to a processor). FS::cust_pay_batch inherits from FS::Record. -Typically called by the collect method of an FS::cust_main object. The -following fields are currently supported: - -=over 4 - -=item trancode - 77 for charges - -=item cardnum - -=item exp - card expiration - -=item amount - -=item invnum - invoice - -=item custnum - customer - -=item payname - name on card - -=item first - name - -=item last - name - -=item address1 - -=item address2 - -=item city - -=item state - -=item zip - -=item country - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new record. To add the record to the database, see L<"insert">. - -Note that this stores the 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 table { 'cust_pay_batch'; } - -=item insert - -Adds this record to the database. If there is an error, returns the error, -otherwise returns false. - -=item delete - -Delete this record from the database. If there is an error, returns the error, -otherwise returns false. - -=item replace OLD_RECORD - -#inactive -# -#Replaces the OLD_RECORD with this one in the database. If there is an error, -#returns the error, otherwise returns false. - -=cut - -sub replace { - return "Can't (yet?) replace batched transactions!"; -} - -=item check - -Checks all fields to make sure this is a valid transaction. If there is -an error, returns the error, otherwise returns false. Called by the insert -and repalce methods. - -=cut - -sub check { - my $self = shift; - - my $error = - $self->ut_numbern('trancode') - || $self->ut_number('cardnum') - || $self->ut_money('amount') - || $self->ut_number('invnum') - || $self->ut_number('custnum') - || $self->ut_text('address1') - || $self->ut_textn('address2') - || $self->ut_text('city') - || $self->ut_text('state') - ; - - return $error if $error; - - $self->getfield('last') =~ /^([\w \,\.\-\']+)$/ or return "Illegal last name"; - $self->setfield('last',$1); - - $self->first =~ /^([\w \,\.\-\']+)$/ or return "Illegal first name"; - $self->first($1); - - my $cardnum = $self->cardnum; - $cardnum =~ s/\D//g; - $cardnum =~ /^(\d{13,16})$/ - or return "Illegal credit card number"; - $cardnum = $1; - $self->cardnum($cardnum); - validate($cardnum) or return "Illegal credit card number"; - return "Unknown card type" if cardtype($cardnum) eq "Unknown"; - - if ( $self->exp eq '' ) { - return "Expriation date required"; #unless - $self->exp(''); - } else { - if ( $self->exp =~ /^(\d{4})[\/\-](\d{1,2})[\/\-](\d{1,2})$/ ) { - $self->exp("$1-$2-$3"); - } elsif ( $self->exp =~ /^(\d{1,2})[\/\-](\d{2}(\d{2})?)$/ ) { - if ( length($2) == 4 ) { - $self->exp("$2-$1-01"); - } elsif ( $2 > 98 ) { #should pry change to check for "this year" - $self->exp("19$2-$1-01"); - } else { - $self->exp("20$2-$1-01"); - } - } else { - return "Illegal expiration date"; - } - } - - if ( $self->payname eq '' ) { - $self->payname( $self->first. " ". $self->getfield('last') ); - } else { - $self->payname =~ /^([\w \,\.\-\']+)$/ - or return "Illegal billing name"; - $self->payname($1); - } - - $self->zip =~ /^\s*(\w[\w\-\s]{3,8}\w)\s*$/ - or return "Illegal zip: ". $self->zip; - $self->zip($1); - - $self->country =~ /^(\w\w)$/ or return "Illegal \w\wy"; - $self->country($1); - - #check invnum, custnum, ? - - ''; #no error -} - -=back - -=head1 VERSION - -$Id: cust_pay_batch.pm,v 1.5 1999-07-29 07:49:04 ivan Exp $ - -=head1 BUGS - -There should probably be a configuration file with a list of allowed credit -card types. - -=head1 SEE ALSO - -L, L - -=head1 HISTORY - -ivan@voicenet.com 97-jul-1 - -added hfields -ivan@sisd.com 97-nov-13 - -$Log: cust_pay_batch.pm,v $ -Revision 1.5 1999-07-29 07:49:04 ivan -fixes for bugs noticed by Joel Griffiths - -Revision 1.4 1999/07/17 22:02:16 ivan -another bug noticed by Steve Gertz - -Revision 1.3 1998/12/29 11:59:44 ivan -mostly properly OO, some work still to be done with svc_ stuff - -Revision 1.2 1998/11/18 09:01:44 ivan -i18n! i18n! - -Revision 1.1 1998/11/15 05:19:58 ivan -long overdue - -Revision 1.3 1998/11/15 04:33:00 ivan -updates for newest versoin - -Revision 1.2 1998/11/15 03:48:49 ivan -update for current version - - -=cut - -1; - diff --git a/site_perl/cust_pkg.pm b/site_perl/cust_pkg.pm deleted file mode 100644 index bbd242972..000000000 --- a/site_perl/cust_pkg.pm +++ /dev/null @@ -1,558 +0,0 @@ -package FS::cust_pkg; - -use strict; -use vars qw(@ISA); -use FS::UID qw( getotaker ); -use FS::Record qw( qsearch qsearchs ); -use FS::cust_svc; -use FS::part_pkg; -use FS::cust_main; -use FS::type_pkgs; - -# need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend, -# setup } -# because they load configuraion by setting FS::UID::callback (see TODO) -use FS::svc_acct; -use FS::svc_acct_sm; -use FS::svc_domain; - -@ISA = qw( FS::Record ); - -=head1 NAME - -FS::cust_pkg - Object methods for cust_pkg objects - -=head1 SYNOPSIS - - use FS::cust_pkg; - - $record = new FS::cust_pkg \%hash; - $record = new FS::cust_pkg { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - - $error = $record->cancel; - - $error = $record->suspend; - - $error = $record->unsuspend; - - $part_pkg = $record->part_pkg; - - @labels = $record->labels; - - $error = FS::cust_pkg::order( $custnum, \@pkgparts ); - $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] ); - -=head1 DESCRIPTION - -An FS::cust_pkg object represents a customer billing item. FS::cust_pkg -inherits from FS::Record. The following fields are currently supported: - -=over 4 - -=item pkgnum - primary key (assigned automatically for new billing items) - -=item custnum - Customer (see L) - -=item pkgpart - Billing item definition (see L) - -=item setup - date - -=item bill - date - -=item susp - date - -=item expire - date - -=item cancel - date - -=item otaker - order taker (assigned automatically if null, see L) - -=back - -Note: setup, bill, susp, expire and cancel are specified as UNIX timestamps; -see L. Also see L and L for -conversion functions. - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Create a new billing item. To add the item to the database, see L<"insert">. - -=cut - -sub table { 'cust_pkg'; } - -=item insert - -Adds this billing item to the database ("Orders" the item). If there is an -error, returns the error, otherwise returns false. - -sub insert { - my $self = shift; - - # custnum might not have have been defined in sub check (for one-shot new - # customers), so check it here instead - - my $error = $self->ut_number('custnum'); - return $error if $error - - return "Unknown customer" - unless qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); - - $self->SUPER::insert; - -} - -=item delete - -Currently unimplemented. You don't want to delete billing items, because there -would then be no record the customer ever purchased the item. Instead, see -the cancel method. - -=cut - -sub delete { - return "Can't delete cust_pkg records!"; -} - -=item replace OLD_RECORD - -Replaces the OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -Currently, custnum, setup, bill, susp, expire, and cancel may be changed. - -Changing pkgpart may have disasterous effects. See the order subroutine. - -setup and bill are normally updated by calling the bill method of a customer -object (see L). - -suspend is normally updated by the suspend and unsuspend methods. - -cancel is normally updated by the cancel method (and also the order subroutine -in some cases). - -=cut - -sub replace { - my( $new, $old ) = ( shift, shift ); - - #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart; - return "Can't change otaker!" if $old->otaker ne $new->otaker; - return "Can't change setup once it exists!" - if $old->getfield('setup') && - $old->getfield('setup') != $new->getfield('setup'); - #some logic for bill, susp, cancel? - - $new->SUPER::replace($old); -} - -=item check - -Checks all fields to make sure this is a valid billing item. If there is an -error, returns the error, otherwise returns false. Called by the insert and -replace methods. - -=cut - -sub check { - my $self = shift; - - my $error = - $self->ut_numbern('pkgnum') - || $self->ut_numbern('custnum') - || $self->ut_number('pkgpart') - || $self->ut_numbern('setup') - || $self->ut_numbern('bill') - || $self->ut_numbern('susp') - || $self->ut_numbern('cancel') - ; - return $error if $error; - - if ( $self->custnum ) { - return "Unknown customer" - unless qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); - } - - return "Unknown pkgpart" - unless qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } ); - - $self->otaker(getotaker) unless $self->otaker; - $self->otaker =~ /^(\w{0,16})$/ or return "Illegal otaker"; - $self->otaker($1); - - ''; #no error -} - -=item cancel - -Cancels and removes all services (see L and L) -in this package, then cancels the package itself (sets the cancel field to -now). - -If there is an error, returns the error, otherwise returns false. - -=cut - -sub cancel { - my $self = shift; - my $error; - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - local $SIG{PIPE} = 'IGNORE'; - - foreach my $cust_svc ( - qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) - ) { - my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } ); - - $part_svc->svcdb =~ /^([\w\-]+)$/ - or return "Illegal svcdb value in part_svc!"; - my $svcdb = $1; - require "FS/$svcdb.pm"; - - my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } ); - if ($svc) { - $error = $svc->cancel; - return "Error cancelling service: $error" if $error; - $error = $svc->delete; - return "Error deleting service: $error" if $error; - } - - $error = $cust_svc->delete; - return "Error deleting cust_svc: $error" if $error; - - } - - unless ( $self->getfield('cancel') ) { - my %hash = $self->hash; - $hash{'cancel'} = time; - my $new = new FS::cust_pkg ( \%hash ); - $error = $new->replace($self); - return $error if $error; - } - - ''; #no errors -} - -=item suspend - -Suspends all services (see L and L) in this -package, then suspends the package itself (sets the susp field to now). - -If there is an error, returns the error, otherwise returns false. - -=cut - -sub suspend { - my $self = shift; - my $error ; - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - local $SIG{PIPE} = 'IGNORE'; - - foreach my $cust_svc ( - qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) - ) { - my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } ); - - $part_svc->svcdb =~ /^([\w\-]+)$/ - or return "Illegal svcdb value in part_svc!"; - my $svcdb = $1; - require "FS/$svcdb.pm"; - - my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } ); - if ($svc) { - $error = $svc->suspend; - return $error if $error; - } - - } - - unless ( $self->getfield('susp') ) { - my %hash = $self->hash; - $hash{'susp'} = time; - my $new = new FS::cust_pkg ( \%hash ); - $error = $new->replace($self); - return $error if $error; - } - - ''; #no errors -} - -=item unsuspend - -Unsuspends all services (see L and L) in this -package, then unsuspends the package itself (clears the susp field). - -If there is an error, returns the error, otherwise returns false. - -=cut - -sub unsuspend { - my $self = shift; - my($error); - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - local $SIG{PIPE} = 'IGNORE'; - - foreach my $cust_svc ( - qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } ) - ) { - my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } ); - - $part_svc->svcdb =~ /^([\w\-]+)$/ - or return "Illegal svcdb value in part_svc!"; - my $svcdb = $1; - require "FS/$svcdb.pm"; - - my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } ); - if ($svc) { - $error = $svc->unsuspend; - return $error if $error; - } - - } - - unless ( ! $self->getfield('susp') ) { - my %hash = $self->hash; - $hash{'susp'} = ''; - my $new = new FS::cust_pkg ( \%hash ); - $error = $new->replace($self); - return $error if $error; - } - - ''; #no errors -} - -=item part_pkg - -Returns the definition for this billing item, as an FS::part_pkg object (see -L $self->pkgpart } ); -} - -=item labels - -Returns a list of lists, calling the label method for all services -(see L) of this billing item. - -=cut - -sub labels { - my $self = shift; - map { [ $_->label ] } qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } ); -} - -=back - -=head1 SUBROUTINES - -=over 4 - -=item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF ] - -CUSTNUM is a customer (see L) - -PKGPARTS is a list of pkgparts specifying the the billing item definitions (see -L) to order for this customer. Duplicates are of course -permitted. - -REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to -remove for this customer. The services (see L) are moved to the -new billing items. An error is returned if this is not possible (see -L). - -=cut - -sub order { - my($custnum,$pkgparts,$remove_pkgnums)=@_; - - # generate %part_pkg - # $part_pkg{$pkgpart} is true iff $custnum may purchase $pkgpart - # - my($cust_main)=qsearchs('cust_main',{'custnum'=>$custnum}); - my($agent)=qsearchs('agent',{'agentnum'=> $cust_main->agentnum }); - my %part_pkg = %{ $agent->pkgpart_hashref }; - - my(%svcnum); - # generate %svcnum - # for those packages being removed: - #@{ $svcnum{$svcpart} } goes from a svcpart to a list of FS::Record - # objects (table eq 'cust_svc') - my($pkgnum); - foreach $pkgnum ( @{$remove_pkgnums} ) { - my($cust_svc); - foreach $cust_svc (qsearch('cust_svc',{'pkgnum'=>$pkgnum})) { - push @{ $svcnum{$cust_svc->getfield('svcpart')} }, $cust_svc; - } - } - - my(@cust_svc); - #generate @cust_svc - # for those packages the customer is purchasing: - # @{$pkgparts} is a list of said packages, by pkgpart - # @cust_svc is a corresponding list of lists of FS::Record objects - my($pkgpart); - foreach $pkgpart ( @{$pkgparts} ) { - return "Customer not permitted to purchase pkgpart $pkgpart!" - unless $part_pkg{$pkgpart}; - push @cust_svc, [ - map { - ( $svcnum{$_} && @{ $svcnum{$_} } ) ? shift @{ $svcnum{$_} } : (); - } (split(/,/, - qsearchs('part_pkg',{'pkgpart'=>$pkgpart})->getfield('services') - )) - ]; - } - - #check for leftover services - foreach (keys %svcnum) { - next unless @{ $svcnum{$_} }; - return "Leftover services!"; - } - - #no leftover services, let's make changes. - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - local $SIG{PIPE} = 'IGNORE'; - - #first cancel old packages -# my($pkgnum); - foreach $pkgnum ( @{$remove_pkgnums} ) { - my($old) = qsearchs('cust_pkg',{'pkgnum'=>$pkgnum}); - die "Package $pkgnum not found to remove!" unless $old; - my(%hash) = $old->hash; - $hash{'cancel'}=time; - my($new) = new FS::cust_pkg ( \%hash ); - my($error)=$new->replace($old); - die "Couldn't update package $pkgnum: $error" if $error; - } - - #now add new packages, changing cust_svc records if necessary -# my($pkgpart); - while ($pkgpart=shift @{$pkgparts} ) { - - my($new) = new FS::cust_pkg ( { - 'custnum' => $custnum, - 'pkgpart' => $pkgpart, - } ); - my($error) = $new->insert; - die "Couldn't insert new cust_pkg record: $error" if $error; - my($pkgnum)=$new->getfield('pkgnum'); - - my($cust_svc); - foreach $cust_svc ( @{ shift @cust_svc } ) { - my(%hash) = $cust_svc->hash; - $hash{'pkgnum'}=$pkgnum; - my($new) = new FS::cust_svc ( \%hash ); - my($error)=$new->replace($cust_svc); - die "Couldn't link old service to new package: $error" if $error; - } - } - - ''; #no errors -} - -=back - -=head1 VERSION - -$Id: cust_pkg.pm,v 1.10 1999-07-20 10:37:05 ivan Exp $ - -=head1 BUGS - -sub order is not OO. Perhaps it should be moved to FS::cust_main and made so? - -In sub order, the @pkgparts array (passed by reference) is clobbered. - -Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard -method to pass dates to the recur_prog expression, it should do so. - -FS::svc_acct, FS::svc_acct_sm, and FS::svc_domain are loaded via 'use' at -compile time, rather than via 'require' in sub { setup, suspend, unsuspend, -cancel } because they use %FS::UID::callback to load configuration values. -Probably need a subroutine which decides what to do based on whether or not -we've fetched the user yet, rather than a hash. See FS::UID and the TODO. - -=head1 SEE ALSO - -L, L, L, L -, L, schema.html from the base documentation - -=head1 HISTORY - -ivan@voicenet.com 97-jul-1 - 21 - -fixed for new agent->agent_type->type_pkgs in &order ivan@sisd.com 98-mar-7 - -pod ivan@sisd.com 98-sep-21 - -$Log: cust_pkg.pm,v $ -Revision 1.10 1999-07-20 10:37:05 ivan -cleaned up the new one-screen signup bits in htdocs/edit/cust_main.cgi to -prepare for a signup server - -Revision 1.9 1999/03/29 01:11:51 ivan -use FS::type_pkgs - -Revision 1.8 1999/03/25 13:48:14 ivan -allow empty custnum in sub check (but call that an error in sub insert), -for one-screen new customer entry - -Revision 1.7 1999/02/09 09:55:06 ivan -invoices show line items for each service in a package (see the label method -of FS::cust_svc) - -Revision 1.6 1999/01/25 12:26:12 ivan -yet more mod_perl stuff - -Revision 1.5 1999/01/18 21:58:07 ivan -esthetic: eq and ne were used in a few places instead of == and != - -Revision 1.4 1998/12/29 11:59:45 ivan -mostly properly OO, some work still to be done with svc_ stuff - -Revision 1.3 1998/11/15 13:01:35 ivan -allow pkgpart changing (for per-customer custom pricing). warn about it in doc - -Revision 1.2 1998/11/12 03:42:45 ivan -added label method - - -=cut - -1; - diff --git a/site_perl/cust_refund.pm b/site_perl/cust_refund.pm deleted file mode 100644 index 4ec54907d..000000000 --- a/site_perl/cust_refund.pm +++ /dev/null @@ -1,204 +0,0 @@ -package FS::cust_refund; - -use strict; -use vars qw( @ISA ); -use Business::CreditCard; -use FS::Record qw( qsearchs ); -use FS::UID qw(getotaker); -use FS::cust_credit; - -@ISA = qw( FS::Record ); - -=head1 NAME - -FS::cust_refund - Object method for cust_refund objects - -=head1 SYNOPSIS - - use FS::cust_refund; - - $record = new FS::cust_refund \%hash; - $record = new FS::cust_refund { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::cust_refund represents a refund. FS::cust_refund inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item refundnum - primary key (assigned automatically for new refunds) - -=item crednum - Credit (see L) - -=item refund - Amount of the refund - -=item _date - specified as a UNIX timestamp; see L. Also see -L and L for conversion functions. - -=item payby - `CARD' (credit cards), `BILL' (billing), or `COMP' (free) - -=item payinfo - card number, P.O.#, or comp issuer (4-8 lowercase alphanumerics; think username) - -=item otaker - order taker (assigned automatically, see L) - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new refund. To add the refund to the database, see L<"insert">. - -=cut - -sub table { 'cust_refund'; } - -=item insert - -Adds this refund to the database, and updates the credit (see -L). - -=cut - -sub insert { - my $self = shift; - - my $error; - - $error=$self->check; - return $error if $error; - - my $old_cust_credit = - qsearchs( 'cust_credit', { 'crednum' => $self->crednum } ); - return "Unknown crednum" unless $old_cust_credit; - my %hash = $old_cust_credit->hash; - $hash{credited} = sprintf("%.2f", $hash{credited} - $self->refund ); - my($new_cust_credit) = new FS::cust_credit ( \%hash ); - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - local $SIG{PIPE} = 'IGNORE'; - - $error = $new_cust_credit->replace($old_cust_credit); - return "Error modifying cust_credit: $error" if $error; - - $self->SUPER::insert; -} - -=item delete - -Currently unimplemented (accounting reasons). - -=cut - -sub delete { - return "Can't (yet?) delete cust_refund records!"; -} - -=item replace OLD_RECORD - -Currently unimplemented (accounting reasons). - -=cut - -sub replace { - return "Can't (yet?) modify cust_refund records!"; -} - -=item check - -Checks all fields to make sure this is a valid refund. If there is an error, -returns the error, otherwise returns false. Called by the insert method. - -=cut - -sub check { - my $self = shift; - - my $error; - - $error = - $self->ut_number('refundnum') - || $self->ut_number('crednum') - || $self->ut_money('amount') - || $self->ut_numbern('_date') - ; - return $error if $error; - - $self->_date(time) unless $self->_date; - - $self->payby =~ /^(CARD|BILL|COMP)$/ or return "Illegal payby"; - $self->payby($1); - - if ( $self->payby eq 'CARD' ) { - my $payinfo = $self->payinfo; - $self->payinfo($payinfo =~ s/\D//g); - if ( $self->payinfo ) { - $self->payinfo =~ /^(\d{13,16})$/ - or return "Illegal (mistyped?) credit card number (payinfo)"; - $self->payinfo($1); - validate($self->payinfo) or return "Illegal credit card number"; - return "Unknown card type" if cardtype($self->payinfo) eq "Unknown"; - } else { - $self->payinfo('N/A'); - } - - } else { - $error = $self->ut_textn('payinfo'); - return $error if $error; - } - - $self->otaker(getotaker); - - ''; #no error -} - -=back - -=head1 VERSION - -$Id: cust_refund.pm,v 1.3 1999-01-25 12:26:13 ivan Exp $ - -=head1 BUGS - -Delete and replace methods. - -=head1 SEE ALSO - -L, L, schema.html from the base documentation. - -=head1 HISTORY - -ivan@sisd.com 98-mar-18 - -->create had wrong tablename ivan@sisd.com 98-jun-16 -(finish me!) - -pod and finish up ivan@sisd.com 98-sep-21 - -$Log: cust_refund.pm,v $ -Revision 1.3 1999-01-25 12:26:13 ivan -yet more mod_perl stuff - -Revision 1.2 1998/12/29 11:59:46 ivan -mostly properly OO, some work still to be done with svc_ stuff - - -=cut - -1; - diff --git a/site_perl/cust_svc.pm b/site_perl/cust_svc.pm deleted file mode 100644 index f97f5fe9d..000000000 --- a/site_perl/cust_svc.pm +++ /dev/null @@ -1,189 +0,0 @@ -package FS::cust_svc; - -use strict; -use vars qw( @ISA ); -use Carp qw( cluck ); -use FS::Record qw( qsearchs ); -use FS::cust_pkg; -use FS::part_pkg; -use FS::part_svc; -use FS::svc_acct; -use FS::svc_acct_sm; -use FS::svc_domain; - -@ISA = qw( FS::Record ); - -=head1 NAME - -FS::cust_svc - Object method for cust_svc objects - -=head1 SYNOPSIS - - use FS::cust_svc; - - $record = new FS::cust_svc \%hash - $record = new FS::cust_svc { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - - ($label, $value) = $record->label; - -=head1 DESCRIPTION - -An FS::cust_svc represents a service. FS::cust_svc inherits from FS::Record. -The following fields are currently supported: - -=over 4 - -=item svcnum - primary key (assigned automatically for new services) - -=item pkgnum - Package (see L) - -=item svcpart - Service definition (see L) - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new service. To add the refund to the database, see L<"insert">. -Services are normally created by creating FS::svc_ objects (see -L, L, and L, among others). - -=cut - -sub table { 'cust_svc'; } - -=item insert - -Adds this service to the database. If there is an error, returns the error, -otherwise returns false. - -=item delete - -Deletes this service from the database. If there is an error, returns the -error, otherwise returns false. - -Called by the cancel method of the package (see L). - -=item replace OLD_RECORD - -Replaces the OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -=item check - -Checks all fields to make sure this is a valid service. If there is an error, -returns the error, otehrwise returns false. Called by the insert and -replace methods. - -=cut - -sub check { - my $self = shift; - - my $error = - $self->ut_numbern('svcnum') - || $self->ut_numbern('pkgnum') - || $self->ut_number('svcpart') - ; - return $error if $error; - - return "Unknown pkgnum" - unless ! $self->pkgnum - || qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } ); - - return "Unknown svcpart" unless - qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } ); - - ''; #no error -} - -=item label - -Returns a list consisting of: -- The name of this service (from part_svc) -- A meaningful identifier (username, domain, or mail alias) -- The table name (i.e. svc_domain) for this service - -=cut - -sub label { - my $self = shift; - my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } ); - my $svcdb = $part_svc->svcdb; - my $svc_x = qsearchs( $svcdb, { 'svcnum' => $self->svcnum } ); - my $svc = $part_svc->svc; - my $tag; - if ( $svcdb eq 'svc_acct' ) { - $tag = $svc_x->getfield('username'); - } elsif ( $svcdb eq 'svc_acct_sm' ) { - my $domuser = $svc_x->domuser eq '*' ? '(anything)' : $svc_x->domuser; - my $svc_domain = qsearchs ( 'svc_domain', { 'svcnum' => $svc_x->domsvc } ); - my $domain = $svc_domain->domain; - $tag = "$domuser\@$domain"; - } elsif ( $svcdb eq 'svc_domain' ) { - $tag = $svc_x->getfield('domain'); - } else { - cluck "warning: asked for label of unsupported svcdb; using svcnum"; - $tag = $svc_x->getfield('svcnum'); - } - $svc, $tag, $svcdb; -} - -=back - -=head1 VERSION - -$Id: cust_svc.pm,v 1.5 1998-12-29 11:59:47 ivan Exp $ - -=head1 BUGS - -Behaviour of changing the svcpart of cust_svc records is undefined and should -possibly be prohibited, and pkg_svc records are not checked. - -pkg_svc records are not checked in general (here). - -Deleting this record doesn't check or delete the svc_* record associated -with this record. - -=head1 SEE ALSO - -L, L, L, L, -schema.html from the base documentation - -=head1 HISTORY - -ivan@voicenet.com 97-jul-10,14 - -no TableUtil, no FS::Lock ivan@sisd.com 98-mar-7 - -pod ivan@sisd.com 98-sep-21 - -$Log: cust_svc.pm,v $ -Revision 1.5 1998-12-29 11:59:47 ivan -mostly properly OO, some work still to be done with svc_ stuff - -Revision 1.4 1998/11/12 07:58:15 ivan -added svcdb to label - -Revision 1.3 1998/11/12 03:45:38 ivan -use FS::table_name for all tables qsearch()'ed - -Revision 1.2 1998/11/12 03:32:46 ivan -added label method - - -=cut - -1; - diff --git a/site_perl/dbdef.pm b/site_perl/dbdef.pm deleted file mode 100644 index ac31bff0b..000000000 --- a/site_perl/dbdef.pm +++ /dev/null @@ -1,174 +0,0 @@ -package FS::dbdef; - -use strict; -use vars qw(@ISA); -use Exporter; -use Carp; -use FreezeThaw qw(freeze thaw cmpStr); -use FS::dbdef_table; -use FS::dbdef_unique; -use FS::dbdef_index; -use FS::dbdef_column; - -@ISA = qw(Exporter); - -=head1 NAME - -FS::dbdef - Database objects - -=head1 SYNOPSIS - - use FS::dbdef; - - $dbdef = new FS::dbdef (@dbdef_table_objects); - $dbdef = load FS::dbdef "filename"; - - $dbdef->save("filename"); - - $dbdef->addtable($dbdef_table_object); - - @table_names = $dbdef->tables; - - $FS_dbdef_table_object = $dbdef->table; - -=head1 DESCRIPTION - -FS::dbdef objects are collections of FS::dbdef_table objects and represnt -a database (a collection of tables). - -=head1 METHODS - -=over 4 - -=item new TABLE, TABLE, ... - -Creates a new FS::dbdef object - -=cut - -sub new { - my($proto,@tables)=@_; - my(%tables)=map { $_->name, $_ } @tables; #check for duplicates? - - my($class) = ref($proto) || $proto; - my($self) = { - 'tables' => \%tables, - }; - - bless ($self, $class); - -} - -=item load FILENAME - -Loads an FS::dbdef object from a file. - -=cut - -sub load { - my($proto,$file)=@_; #use $proto ? - open(FILE,"<$file") or die "Can't open $file: $!"; - my($string)=join('',); #can $string have newlines? pry not? - close FILE or die "Can't close $file: $!"; - my($self)=thaw $string; - #no bless needed? - $self; -} - -=item save FILENAME - -Saves an FS::dbdef object to a file. - -=cut - -sub save { - my($self,$file)=@_; - my($string)=freeze $self; - open(FILE,">$file") or die "Can't open $file: $!"; - print FILE $string; - close FILE or die "Can't close file: $!"; - my($check_self)=thaw $string; - die "Verify error: Can't freeze and thaw dbdef $self" - if (cmpStr($self,$check_self)); -} - -=item addtable TABLE - -Adds this FS::dbdef_table object. - -=cut - -sub addtable { - my($self,$table)=@_; - ${$self->{'tables'}}{$table->name}=$table; #check for dupliates? -} - -=item tables - -Returns the names of all tables. - -=cut - -sub tables { - my($self)=@_; - keys %{$self->{'tables'}}; -} - -=item table TABLENAME - -Returns the named FS::dbdef_table object. - -=cut - -sub table { - my($self,$table)=@_; - $self->{'tables'}->{$table}; -} - -=head1 BUGS - -Each FS::dbdef object should have a name which corresponds to its name within -the SQL database engine. - -=head1 SEE ALSO - -L, L, - -=head1 HISTORY - -beginning of abstraction into a class (not really) - -ivan@sisd.com 97-dec-4 - -added primary_key -ivan@sisd.com 98-jan-20 - -added datatype (very kludgy and needs to be cleaned) -ivan@sisd.com 98-feb-21 - -perltrap (sigh) masked by mysql 3.20->3,21 ivan@sisd.com 98-mar-2 - -Change 'type' to 'atype' in agent_type -Changed attributes to special words which are changed in fs-setup - ie. double(10,2) <=> MONEYTYPE -Changed order of some of the field definitions because Pg6.3 is picky -Changed 'day' to 'daytime' in cust_main -Changed type of tax from tinyint to real -Change 'password' to '_password' in svc_acct -Pg6.3 does not allow 'field char(x) NULL' - bmccane@maxbaud.net 98-apr-3 - -rewrite: now properly OO. See also FS::dbdef_{table,column,unique,index} - -ivan@sisd.com 98-apr-17 - -gained some extra functions ivan@sisd.com 98-may-11 - -now knows how to Freeze and Thaw itself ivan@sisd.com 98-jun-2 - -pod ivan@sisd.com 98-sep-23 - -=cut - -1; - diff --git a/site_perl/dbdef_colgroup.pm b/site_perl/dbdef_colgroup.pm deleted file mode 100644 index 43be04430..000000000 --- a/site_perl/dbdef_colgroup.pm +++ /dev/null @@ -1,108 +0,0 @@ -package FS::dbdef_colgroup; - -use strict; -use vars qw(@ISA); -use Exporter; - -@ISA = qw(Exporter); - -=head1 NAME - -FS::dbdef_colgroup - Column group objects - -=head1 SYNOPSIS - - use FS::dbdef_colgroup; - - $colgroup = new FS::dbdef_colgroup ( $lol ); - $colgroup = new FS::dbdef_colgroup ( - [ - [ 'single_column' ], - [ 'multiple_columns', 'another_column', ], - ] - ); - - @sql_lists = $colgroup->sql_list; - - @singles = $colgroup->singles; - -=head1 DESCRIPTION - -FS::dbdef_colgroup objects represent sets of sets of columns. - -=head1 METHODS - -=over 4 - -=item new - -Creates a new FS::dbdef_colgroup object. - -=cut - -sub new { - my($proto, $lol) = @_; - - my $class = ref($proto) || $proto; - my $self = { - 'lol' => $lol, - }; - - bless ($self, $class); - -} - -=item sql_list - -Returns a flat list of comma-separated values, for SQL statements. - -=cut - -sub sql_list { #returns a flat list of comman-separates lists (for sql) - my($self)=@_; - grep $_ ne '', map join(', ', @{$_}), @{$self->{'lol'}}; -} - -=item singles - -Returns a flat list of all single item lists. - -=cut - -sub singles { #returns single-field groups as a flat list - my($self)=@_; - #map ${$_}[0], grep scalar(@{$_}) == 1, @{$self->{'lol'}}; - map { - ${$_}[0] =~ /^(\w+)$/ - #aah! - or die "Illegal column ", ${$_}[0], " in colgroup!"; - $1; - } grep scalar(@{$_}) == 1, @{$self->{'lol'}}; -} - -=back - -=head1 BUGS - -=head1 SEE ALSO - -L, L, L, -L, L, L - -=head1 HISTORY - -class for dealing with groups of groups of columns (used as a base class by -FS::dbdef_{unique,index} ) - -ivan@sisd.com 98-apr-19 - -added singles, fixed sql_list to skip empty lists ivan@sisd.com 98-jun-2 - -untaint things we're returning in sub singels ivan@sisd.com 98-jun-4 - -pod ivan@sisd.com 98-sep-24 - -=cut - -1; - diff --git a/site_perl/dbdef_column.pm b/site_perl/dbdef_column.pm deleted file mode 100644 index dc07305b8..000000000 --- a/site_perl/dbdef_column.pm +++ /dev/null @@ -1,192 +0,0 @@ -package FS::dbdef_column; - -use strict; -#use Carp; -use Exporter; -use vars qw(@ISA); - -@ISA = qw(Exporter); - -=head1 NAME - -FS::dbdef_column - Column object - -=head1 SYNOPSIS - - use FS::dbdef_column; - - $column_object = new FS::dbdef_column ( $name, $sql_type, '' ); - $column_object = new FS::dbdef_column ( $name, $sql_type, 'NULL' ); - $column_object = new FS::dbdef_column ( $name, $sql_type, '', $length ); - $column_object = new FS::dbdef_column ( $name, $sql_type, 'NULL', $length ); - - $name = $column_object->name; - $column_object->name ( 'name' ); - - $name = $column_object->type; - $column_object->name ( 'sql_type' ); - - $name = $column_object->null; - $column_object->name ( 'NOT NULL' ); - - $name = $column_object->length; - $column_object->name ( $length ); - - $sql_line = $column->line; - $sql_line = $column->line $datasrc; - -=head1 DESCRIPTION - -FS::dbdef::column objects represend columns in tables (see L). - -=head1 METHODS - -=over 4 - -=item new - -Creates a new FS::dbdef_column object. - -=cut - -sub new { - my($proto,$name,$type,$null,$length)=@_; - - #croak "Illegal name: $name" if grep $name eq $_, @reserved_words; - - $null =~ s/^NOT NULL$//i; - - my $class = ref($proto) || $proto; - my $self = { - 'name' => $name, - 'type' => $type, - 'null' => $null, - 'length' => $length, - }; - - bless ($self, $class); - -} - -=item name - -Returns or sets the column name. - -=cut - -sub name { - my($self,$value)=@_; - if ( defined($value) ) { - #croak "Illegal name: $name" if grep $name eq $_, @reserved_words; - $self->{'name'} = $value; - } else { - $self->{'name'}; - } -} - -=item type - -Returns or sets the column type. - -=cut - -sub type { - my($self,$value)=@_; - if ( defined($value) ) { - $self->{'type'} = $value; - } else { - $self->{'type'}; - } -} - -=item null - -Returns or sets the column null flag. - -=cut - -sub null { - my($self,$value)=@_; - if ( defined($value) ) { - $value =~ s/^NOT NULL$//i; - $self->{'null'} = $value; - } else { - $self->{'null'}; - } -} - -=item type - -Returns or sets the column length. - -=cut - -sub length { - my($self,$value)=@_; - if ( defined($value) ) { - $self->{'length'} = $value; - } else { - $self->{'length'}; - } -} - -=item line [ $datasrc ] - -Returns an SQL column definition. - -If passed a DBI $datasrc specifying L or L, will use -engine-specific syntax. - -=cut - -sub line { - my($self,$datasrc)=@_; - my($null)=$self->null; - if ( $datasrc =~ /mysql/ ) { #yucky mysql hack - $null ||= "NOT NULL" - } - if ( $datasrc =~ /Pg/ ) { #yucky Pg hack - $null ||= "NOT NULL"; - $null =~ s/^NULL$//; - } - join(' ', - $self->name, - $self->type. ( $self->length ? '('.$self->length.')' : '' ), - $null, - ); -} - -=back - -=head1 BUGS - -=head1 SEE ALSO - -L, L, L - -=head1 VERSION - -$Id: dbdef_column.pm,v 1.3 1998-10-13 13:04:17 ivan Exp $ - -=head1 HISTORY - -class for dealing with column definitions - -ivan@sisd.com 98-apr-17 - -now methods can be used to get or set data ivan@sisd.com 98-may-11 - -mySQL-specific hack for null (what should be default?) ivan@sisd.com 98-jun-2 - -$Log: dbdef_column.pm,v $ -Revision 1.3 1998-10-13 13:04:17 ivan -fixed doc to indicate Pg specific syntax too - -Revision 1.2 1998/10/12 23:40:28 ivan -added Pg-specific behaviour in sub line - - -=cut - -1; - diff --git a/site_perl/dbdef_index.pm b/site_perl/dbdef_index.pm deleted file mode 100644 index 2097db1ea..000000000 --- a/site_perl/dbdef_index.pm +++ /dev/null @@ -1,43 +0,0 @@ -package FS::dbdef_index; - -use strict; -use vars qw(@ISA); -use FS::dbdef_colgroup; - -@ISA=qw(FS::dbdef_colgroup); - -=head1 NAME - -FS::dbdef_unique.pm - Index object - -=head1 SYNOPSIS - - use FS::dbdef_index; - - # see FS::dbdef_colgroup methods - -=head1 DESCRIPTION - -FS::dbdef_unique objects represent the (non-unique) indices of a table -(L). FS::dbdef_unique inherits from FS::dbdef_colgroup. - -=head1 BUGS - -Is this empty subclass needed? - -=head1 SEE ALSO - -L, L, L - -=head1 HISTORY - -class for dealing with index definitions - -ivan@sisd.com 98-apr-19 - -pod ivan@sisd.com 98-sep-24 - -=cut - -1; - diff --git a/site_perl/dbdef_table.pm b/site_perl/dbdef_table.pm deleted file mode 100644 index 8c5bcfe77..000000000 --- a/site_perl/dbdef_table.pm +++ /dev/null @@ -1,258 +0,0 @@ -package FS::dbdef_table; - -use strict; -#use Carp; -use Exporter; -use vars qw(@ISA); -use FS::dbdef_column; - -@ISA = qw(Exporter); - -=head1 NAME - -FS::dbdef_table - Table objects - -=head1 SYNOPSIS - - use FS::dbdef_table; - - $dbdef_table = new FS::dbdef_table ( - "table_name", - "primary_key", - $FS_dbdef_unique_object, - $FS_dbdef_index_object, - @FS_dbdef_column_objects, - ); - - $dbdef_table->addcolumn ( $FS_dbdef_column_object ); - - $table_name = $dbdef_table->name; - $dbdef_table->name ("table_name"); - - $table_name = $dbdef_table->primary_keye; - $dbdef_table->primary_key ("primary_key"); - - $FS_dbdef_unique_object = $dbdef_table->unique; - $dbdef_table->unique ( $FS_dbdef_unique_object ); - - $FS_dbdef_index_object = $dbdef_table->index; - $dbdef_table->index ( $FS_dbdef_index_object ); - - @column_names = $dbdef->columns; - - $FS_dbdef_column_object = $dbdef->column; - - @sql_statements = $dbdef->sql_create_table; - @sql_statements = $dbdef->sql_create_table $datasrc; - -=head1 DESCRIPTION - -FS::dbdef_table objects represent a single database table. - -=head1 METHODS - -=over 4 - -=item new - -Creates a new FS::dbdef_table object. - -=cut - -sub new { - my($proto,$name,$primary_key,$unique,$index,@columns)=@_; - - my(%columns) = map { $_->name, $_ } @columns; - - #check $primary_key, $unique and $index to make sure they are $columns ? - # (and sanity check?) - - my $class = ref($proto) || $proto; - my $self = { - 'name' => $name, - 'primary_key' => $primary_key, - 'unique' => $unique, - 'index' => $index, - 'columns' => \%columns, - }; - - bless ($self, $class); - -} - -=item addcolumn - -Adds this FS::dbdef_column object. - -=cut - -sub addcolumn { - my($self,$column)=@_; - ${$self->{'columns'}}{$column->name}=$column; #sanity check? -} - -=item name - -Returns or sets the table name. - -=cut - -sub name { - my($self,$value)=@_; - if ( defined($value) ) { - $self->{name} = $value; - } else { - $self->{name}; - } -} - -=item primary_key - -Returns or sets the primary key. - -=cut - -sub primary_key { - my($self,$value)=@_; - if ( defined($value) ) { - $self->{primary_key} = $value; - } else { - #$self->{primary_key}; - #hmm. maybe should untaint the entire structure when it comes off disk - # cause if you don't trust that, ? - $self->{primary_key} =~ /^(\w*)$/ - #aah! - or die "Illegal primary key ", $self->{primary_key}, " in dbdef!\n"; - $1; - } -} - -=item unique - -Returns or sets the FS::dbdef_unique object. - -=cut - -sub unique { - my($self,$value)=@_; - if ( defined($value) ) { - $self->{unique} = $value; - } else { - $self->{unique}; - } -} - -=item index - -Returns or sets the FS::dbdef_index object. - -=cut - -sub index { - my($self,$value)=@_; - if ( defined($value) ) { - $self->{'index'} = $value; - } else { - $self->{'index'}; - } -} - -=item columns - -Returns a list consisting of the names of all columns. - -=cut - -sub columns { - my($self)=@_; - keys %{$self->{'columns'}}; -} - -=item column "column" - -Returns the column object (see L) for "column". - -=cut - -sub column { - my($self,$column)=@_; - $self->{'columns'}->{$column}; -} - -=item sql_create_table [ $datasrc ] - -Returns an array of SQL statments to create this table. - -If passed a DBI $datasrc specifying L, will use MySQL-specific -syntax. Non-standard syntax for other engines (if applicable) may also be -supported in the future. - -=cut - -sub sql_create_table { - my($self,$datasrc)=@_; - - my(@columns)=map { $self->column($_)->line($datasrc) } $self->columns; - push @columns, "PRIMARY KEY (". $self->primary_key. ")" - if $self->primary_key; - if ( $datasrc =~ /mysql/ ) { #yucky mysql hack - push @columns, map "UNIQUE ($_)", $self->unique->sql_list; - push @columns, map "INDEX ($_)", $self->index->sql_list; - } - - "CREATE TABLE ". $self->name. " ( ". join(", ", @columns). " )", - ( map { - my($index) = $self->name. "__". $_ . "_index"; - $index =~ s/,\s*/_/g; - "CREATE UNIQUE INDEX $index ON ". $self->name. " ($_)" - } $self->unique->sql_list ), - ( map { - my($index) = $self->name. "__". $_ . "_index"; - $index =~ s/,\s*/_/g; - "CREATE INDEX $index ON ". $self->name. " ($_)" - } $self->index->sql_list ), - ; - - -} - -=back - -=head1 BUGS - -=head1 SEE ALSO - -L, L, L, L, -L - -=head1 VERSION - -$Id: dbdef_table.pm,v 1.2 1998-10-14 07:05:06 ivan Exp $ - -=head1 HISTORY - -class for dealing with table definitions - -ivan@sisd.com 98-apr-18 - -gained extra functions (should %columns be an IxHash?) -ivan@sisd.com 98-may-11 - -sql_create_table returns a list of statments, not just one, and now it -does indices (plus mysql hack) ivan@sisd.com 98-jun-2 - -untaint primary_key... hmm. is this a hack around a bigger problem? -looks like, did the same thing singles in colgroup! -ivan@sisd.com 98-jun-4 - -pod ivan@sisd.com 98-sep-24 - -$Log: dbdef_table.pm,v $ -Revision 1.2 1998-10-14 07:05:06 ivan -1.1.4 release, fix postgresql - - -=cut - -1; - diff --git a/site_perl/dbdef_unique.pm b/site_perl/dbdef_unique.pm deleted file mode 100644 index 4ec40de60..000000000 --- a/site_perl/dbdef_unique.pm +++ /dev/null @@ -1,44 +0,0 @@ -package FS::dbdef_unique; - -use strict; -use vars qw(@ISA); -use FS::dbdef_colgroup; - -@ISA=qw(FS::dbdef_colgroup); - -=head1 NAME - -FS::dbdef_unique.pm - Unique object - -=head1 SYNOPSIS - - use FS::dbdef_unique; - - # see FS::dbdef_colgroup methods - -=head1 DESCRIPTION - -FS::dbdef_unique objects represent the unique indices of a database table -(L). FS::dbdef_unique inherits from FS::dbdef_colgroup. - -=head1 BUGS - -Is this empty subclass needed? - -=head1 SEE ALSO - -L, L, L - -=head1 HISTORY - -class for dealing with unique definitions - -ivan@sisd.com 98-apr-19 - -pod ivan@sisd.com 98-sep-24 - -=cut - -1; - - diff --git a/site_perl/part_pkg.pm b/site_perl/part_pkg.pm deleted file mode 100644 index 556146e38..000000000 --- a/site_perl/part_pkg.pm +++ /dev/null @@ -1,204 +0,0 @@ -package FS::part_pkg; - -use strict; -use vars qw( @ISA ); -use FS::Record qw( qsearch ); -use FS::pkg_svc; - -@ISA = qw( FS::Record ); - -=head1 NAME - -FS::part_pkg - Object methods for part_pkg objects - -=head1 SYNOPSIS - - use FS::part_pkg; - - $record = new FS::part_pkg \%hash - $record = new FS::part_pkg { 'column' => 'value' }; - - $custom_record = $template_record->clone; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - - @pkg_svc = $record->pkg_svc; - - $svcnum = $record->svcpart; - $svcnum = $record->svcpart( 'svc_acct' ); - -=head1 DESCRIPTION - -An FS::part_pkg object represents a billing item definition. FS::part_pkg -inherits from FS::Record. The following fields are currently supported: - -=over 4 - -=item pkgpart - primary key (assigned automatically for new billing item definitions) - -=item pkg - Text name of this billing item definition (customer-viewable) - -=item comment - Text name of this billing item definition (non-customer-viewable) - -=item setup - Setup fee - -=item freq - Frequency of recurring fee - -=item recur - Recurring fee - -=back - -setup and recur are evaluated as Safe perl expressions. You can use numbers -just as you would normally. More advanced semantics are not yet defined. - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new billing item definition. To add the billing item definition to -the database, see L<"insert">. - -=cut - -sub table { 'part_pkg'; } - -=item clone - -An alternate constructor. Creates a new billing item definition by duplicating -an existing definition. A new pkgpart is assigned and `(CUSTOM) ' is prepended -to the comment field. To add the billing item definition to the database, see -L<"insert">. - -=cut - -sub clone { - my $self = shift; - my $class = ref($self); - my %hash = $self->hash; - $hash{'pkgpart'} = ''; - $hash{'comment'} = "(CUSTOM) ". $hash{'comment'} - unless $hash{'comment'} =~ /^\(CUSTOM\) /; - #new FS::part_pkg ( \%hash ); # ? - new $class ( \%hash ); # ? -} - -=item insert - -Adds this billing item definition to the database. If there is an error, -returns the error, otherwise returns false. - -=item delete - -Currently unimplemented. - -=cut - -sub delete { - return "Can't (yet?) delete package definitions."; -# check & make sure the pkgpart isn't in cust_pkg or type_pkgs? -} - -=item replace OLD_RECORD - -Replaces OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -=item check - -Checks all fields to make sure this is a valid billing item definition. If -there is an error, returns the error, otherwise returns false. Called by the -insert and replace methods. - -=cut - -sub check { - my $self = shift; - - $self->ut_numbern('pkgpart') - || $self->ut_text('pkg') - || $self->ut_text('comment') - || $self->ut_anything('setup') - || $self->ut_number('freq') - || $self->ut_anything('recur') - ; -} - -=item pkg_svc - -Returns all FS::pkg_svc objects (see L) for this package -definition. - -=cut - -sub pkg_svc { - my $self = shift; - qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } ); -} - -=item svcpart [ SVCDB ] - -Returns the svcpart of a single service definition (see L) -associated with this billing item definition (see L). Returns -false if there not exactly one service definition with quantity 1, or if -SVCDB is specified and does not match the svcdb of the service definition, - -=cut - -sub svcpart { - my $self = shift; - my $svcdb = shift; - my @pkg_svc = $self->pkg_svc; - return '' if scalar(@pkg_svc) != 1 - || $pkg_svc[0]->quantity != 1 - || ( $svcdb && $pkg_svc[0]->part_svc->svcdb ne $svcdb ); - $pkg_svc[0]->svcpart; -} - -=back - -=head1 VERSION - -$Id: part_pkg.pm,v 1.6 1999-07-20 10:37:05 ivan Exp $ - -=head1 BUGS - -The delete method is unimplemented. - -setup and recur semantics are not yet defined (and are implemented in -FS::cust_bill. hmm.). - -=head1 SEE ALSO - -L, L, L, L, L. -schema.html from the base documentation. - -=head1 HISTORY - -ivan@sisd.com 97-dec-5 - -pod ivan@sisd.com 98-sep-21 - -$Log: part_pkg.pm,v $ -Revision 1.6 1999-07-20 10:37:05 ivan -cleaned up the new one-screen signup bits in htdocs/edit/cust_main.cgi to -prepare for a signup server - -Revision 1.5 1998/12/31 01:04:16 ivan -doc - -Revision 1.3 1998/11/15 13:00:15 ivan -bugfix in clone method, clone method doc clarification - - -=cut - -1; - diff --git a/site_perl/part_referral.pm b/site_perl/part_referral.pm deleted file mode 100644 index e63e822a8..000000000 --- a/site_perl/part_referral.pm +++ /dev/null @@ -1,123 +0,0 @@ -package FS::part_referral; - -use strict; -use vars qw( @ISA ); -use FS::Record; - -@ISA = qw( FS::Record ); - -=head1 NAME - -FS::part_referral - Object methods for part_referral objects - -=head1 SYNOPSIS - - use FS::part_referral; - - $record = new FS::part_referral \%hash - $record = new FS::part_referral { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::part_referral represents a referral - where a customer heard of your -services. This can be used to track the effectiveness of a particular piece of -advertising, for example. FS::part_referral inherits from FS::Record. The -following fields are currently supported: - -=over 4 - -=item refnum - primary key (assigned automatically for new referrals) - -=item referral - Text name of this referral - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new referral. To add the referral to the database, see L<"insert">. - -=cut - -sub table { 'part_referral'; } - -=item insert - -Adds this referral to the database. If there is an error, returns the error, -otherwise returns false. - -=item delete - -Currently unimplemented. - -=cut - -sub delete { - my $self = shift; - return "Can't (yet?) delete part_referral records"; - #need to make sure no customers have this referral! -} - -=item replace OLD_RECORD - -Replaces OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -=item check - -Checks all fields to make sure this is a valid referral. If there is an error, -returns the error, otherwise returns false. Called by the insert and replace -methods. - -=cut - -sub check { - my $self = shift; - - $self->ut_numbern('refnum') - || $self->ut_text('referral') - ; -} - -=back - -=head1 VERSION - -$Id: part_referral.pm,v 1.2 1998-12-29 11:59:49 ivan Exp $ - -=head1 BUGS - -The delete method is unimplemented. - -=head1 SEE ALSO - -L, L, schema.html from the base documentation. - -=head1 HISTORY - -Class dealing with referrals - -ivan@sisd.com 98-feb-23 - -pod ivan@sisd.com 98-sep-21 - -$Log: part_referral.pm,v $ -Revision 1.2 1998-12-29 11:59:49 ivan -mostly properly OO, some work still to be done with svc_ stuff - - -=cut - -1; - diff --git a/site_perl/part_svc.pm b/site_perl/part_svc.pm deleted file mode 100644 index 6b3ba3d9f..000000000 --- a/site_perl/part_svc.pm +++ /dev/null @@ -1,182 +0,0 @@ -package FS::part_svc; - -use strict; -use vars qw( @ISA ); -use FS::Record qw( fields ); - -@ISA = qw(FS::Record); - -=head1 NAME - -FS::part_svc - Object methods for part_svc objects - -=head1 SYNOPSIS - - use FS::part_svc; - - $record = new FS::part_referral \%hash - $record = new FS::part_referral { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::part_svc represents a service definition. FS::part_svc inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item svcpart - primary key (assigned automatically for new service definitions) - -=item svc - text name of this service definition - -=item svcdb - table used for this service. See L, -L, and L, among others. - -=item I__I - Default or fixed value for I in I. - -=item I__I_flag - defines I__I action: null, `D' for default, or `F' for fixed - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new service definition. To add the service definition to the -database, see L<"insert">. - -=cut - -sub table { 'part_svc'; } - -=item insert - -Adds this service definition to the database. If there is an error, returns -the error, otherwise returns false. - -=item delete - -Currently unimplemented. - -=cut - -sub delete { - return "Can't (yet?) delete service definitions."; -# check & make sure the svcpart isn't in cust_svc or pkg_svc (in any packages)? -} - -=item replace OLD_RECORD - -Replaces OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -=cut - -sub replace { - my ( $new, $old ) = ( shift, shift ); - - return "Can't change svcdb!" - unless $old->svcdb eq $new->svcdb; - - $new->SUPER::replace( $old ); -} - -=item check - -Checks all fields to make sure this is a valid service definition. If there is -an error, returns the error, otherwise returns false. Called by the insert -and replace methods. - -=cut - -sub check { - my $self = shift; - my $recref = $self->hashref; - - my $error; - $error= - $self->ut_numbern('svcpart') - || $self->ut_text('svc') - || $self->ut_alpha('svcdb') - ; - return $error if $error; - - my @fields = eval { fields( $recref->{svcdb} ) }; #might die - return "Unknown svcdb!" unless @fields; - - my $svcdb; - foreach $svcdb ( qw( - svc_acct svc_acct_sm svc_domain - ) ) { - my @rows = map { /^${svcdb}__(.*)$/; $1 } - grep ! /_flag$/, - grep /^${svcdb}__/, - fields('part_svc'); - foreach my $row (@rows) { - unless ( $svcdb eq $recref->{svcdb} ) { - $recref->{$svcdb.'__'.$row}=''; - $recref->{$svcdb.'__'.$row.'_flag'}=''; - next; - } - $recref->{$svcdb.'__'.$row.'_flag'} =~ /^([DF]?)$/ - or return "Illegal flag for $svcdb $row"; - $recref->{$svcdb.'__'.$row.'_flag'} = $1; - - my $error = $self->ut_anything($svcdb.'__'.$row); - return $error if $error; - - } - } - - ''; #no error -} - -=back - -=head1 VERSION - -$Id: part_svc.pm,v 1.3 1999-02-07 09:59:44 ivan Exp $ - -=head1 BUGS - -Delete is unimplemented. - -The list of svc_* tables is hardcoded. When svc_acct_pop is renamed, this -should be fixed. - -=head1 SEE ALSO - -L, L, L, L, -L, L, L, schema.html from the -base documentation. - -=head1 HISTORY - -ivan@sisd.com 97-nov-14 - -data checking/untainting calls into FS::Record added -ivan@sisd.com 97-dec-6 - -pod ivan@sisd.com 98-sep-21 - -$Log: part_svc.pm,v $ -Revision 1.3 1999-02-07 09:59:44 ivan -more mod_perl fixes, and bugfixes Peter Wemm sent via email - -Revision 1.2 1998/12/29 11:59:50 ivan -mostly properly OO, some work still to be done with svc_ stuff - - -=cut - -1; - diff --git a/site_perl/pkg_svc.pm b/site_perl/pkg_svc.pm deleted file mode 100644 index f28745d28..000000000 --- a/site_perl/pkg_svc.pm +++ /dev/null @@ -1,173 +0,0 @@ -package FS::pkg_svc; - -use strict; -use vars qw( @ISA ); -use FS::Record qw( qsearchs ); -use FS::part_pkg; -use FS::part_svc; - -@ISA = qw( FS::Record ); - -=head1 NAME - -FS::pkg_svc - Object methods for pkg_svc records - -=head1 SYNOPSIS - - use FS::pkg_svc; - - $record = new FS::pkg_svc \%hash; - $record = new FS::pkg_svc { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - - $part_pkg = $record->part_pkg; - - $part_svc = $record->part_svc; - -=head1 DESCRIPTION - -An FS::pkg_svc record links a billing item definition (see L) to -a service definition (see L). FS::pkg_svc inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item pkgpart - Billing item definition (see L) - -=item svcpart - Service definition (see L) - -=item quantity - Quantity of this service definition that this billing item -definition includes - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Create a new record. To add the record to the database, see L<"insert">. - -=cut - -sub table { 'pkg_svc'; } - -=item insert - -Adds this record to the database. If there is an error, returns the error, -otherwise returns false. - -=item delete - -Deletes this record from the database. If there is an error, returns the -error, otherwise returns false. - -=item replace OLD_RECORD - -Replaces OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -=cut - -sub replace { - my ( $new, $old ) = ( shift, shift ); - - return "Can't change pkgpart!" if $old->pkgpart != $new->pkgpart; - return "Can't change svcpart!" if $old->svcpart != $new->svcpart; - - $new->SUPER::replace($old); -} - -=item check - -Checks all fields to make sure this is a valid record. If there is an error, -returns the error, otherwise returns false. Called by the insert and replace -methods. - -=cut - -sub check { - my $self = shift; - - my $error; - $error = - $self->ut_number('pkgpart') - || $self->ut_number('svcpart') - || $self->ut_number('quantity') - ; - return $error if $error; - - return "Unknown pkgpart!" unless $self->part_pkg; - return "Unknown svcpart!" unless $self->part_svc; - - ''; #no error -} - -=item part_pkg - -Returns the FS::part_pkg object (see L). - -=cut - -sub part_pkg { - my $self = shift; - qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } ); -} - -=item part_svc - -Returns the FS::part_svc object (see L). - -=cut - -sub part_svc { - my $self = shift; - qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } ); -} - -=back - -=head1 VERSION - -$Id: pkg_svc.pm,v 1.4 1999-07-20 10:37:05 ivan Exp $ - -=head1 BUGS - -=head1 SEE ALSO - -L, L, L, schema.html from the base -documentation. - -=head1 HISTORY - -ivan@voicenet.com 97-jul-1 - -added hfields -ivan@sisd.com 97-nov-13 - -pod ivan@sisd.com 98-sep-22 - -$Log: pkg_svc.pm,v $ -Revision 1.4 1999-07-20 10:37:05 ivan -cleaned up the new one-screen signup bits in htdocs/edit/cust_main.cgi to -prepare for a signup server - -Revision 1.3 1999/01/18 21:58:08 ivan -esthetic: eq and ne were used in a few places instead of == and != - -Revision 1.2 1998/12/29 11:59:51 ivan -mostly properly OO, some work still to be done with svc_ stuff - - -=cut - -1; - diff --git a/site_perl/svc_Common.pm b/site_perl/svc_Common.pm deleted file mode 100644 index f53e83e48..000000000 --- a/site_perl/svc_Common.pm +++ /dev/null @@ -1,217 +0,0 @@ -package FS::svc_Common; - -use strict; -use vars qw( @ISA ); -use FS::Record qw( qsearchs fields ); -use FS::cust_svc; -use FS::part_svc; - -@ISA = qw( FS::Record ); - -=head1 NAME - -FS::svc_Common - Object method for all svc_ records - -=head1 SYNOPSIS - -use FS::svc_Common; - -@ISA = qw( FS::svc_Common ); - -=head1 DESCRIPTION - -FS::svc_Common is intended as a base class for table-specific classes to -inherit from, i.e. FS::svc_acct. FS::svc_Common inherits from FS::Record. - -=head1 METHODS - -=over 4 - -=item insert - -Adds this record to the database. If there is an error, returns the error, -otherwise returns false. - -The additional fields pkgnum and svcpart (see L) should be -defined. An FS::cust_svc record will be created and inserted. - -=cut - -sub insert { - my $self = shift; - my $error; - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - local $SIG{PIPE} = 'IGNORE'; - - $error = $self->check; - return $error if $error; - - my $svcnum = $self->svcnum; - my $cust_svc; - unless ( $svcnum ) { - $cust_svc = new FS::cust_svc ( { - 'svcnum' => $svcnum, - 'pkgnum' => $self->pkgnum, - 'svcpart' => $self->svcpart, - } ); - $error = $cust_svc->insert; - return $error if $error; - $svcnum = $self->svcnum($cust_svc->svcnum); - } - - $error = $self->SUPER::insert; - if ( $error ) { - $cust_svc->delete if $cust_svc; - return $error; - } - - ''; -} - -=item delete - -Deletes this account from the database. If there is an error, returns the -error, otherwise returns false. - -The corresponding FS::cust_svc record will be deleted as well. - -=cut - -sub delete { - my $self = shift; - my $error; - - 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 $svcnum = $self->svcnum; - - $error = $self->SUPER::delete; - return $error if $error; - - my $cust_svc = qsearchs( 'cust_svc' , { 'svcnum' => $svcnum } ); - $error = $cust_svc->delete; - return $error if $error; - - ''; -} - -=item setfixed - -Sets any fixed fields for this service (see L). If there is an -error, returns the error, otherwise returns the FS::part_svc object (use ref() -to test the return). Usually called by the check method. - -=cut - -sub setfixed { - my $self = shift; - $self->setx('F'); -} - -=item setdefault - -Sets all fields to their defaults (see L), overriding their -current values. If there is an error, returns the error, otherwise returns -the FS::part_svc object (use ref() to test the return). - -=cut - -sub setdefault { - my $self = shift; - $self->setx('D'); -} - -sub setx { - my $self = shift; - my $x = shift; - - my $error; - - $error = - $self->ut_numbern('svcnum') - ; - return $error if $error; - - #get part_svc - my $svcpart; - if ( $self->svcnum ) { - my $cust_svc = qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } ); - return "Unknown svcnum" unless $cust_svc; - $svcpart = $cust_svc->svcpart; - } else { - $svcpart = $self->getfield('svcpart'); - } - my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $svcpart } ); - return "Unkonwn svcpart" unless $part_svc; - - #set default/fixed/whatever fields from part_svc - foreach my $field ( fields('svc_acct') ) { - if ( $part_svc->getfield('svc_acct__'. $field. '_flag') eq $x ) { - $self->setfield( $field, $part_svc->getfield('svc_acct__'. $field) ); - } - } - - $part_svc; - -} - -=item suspend - -=item unsuspend - -=item cancel - -Stubs - return false (no error) so derived classes don't need to define these -methods. Called by the cancel method of FS::cust_pkg (see L). - -=cut - -sub suspend { ''; } -sub unsuspend { ''; } -sub cancel { ''; } - -=back - -=head1 VERSION - -$Id: svc_Common.pm,v 1.3 1999-03-25 13:31:29 ivan Exp $ - -=head1 BUGS - -The setfixed method return value. - -The new method should set defaults from part_svc (like the check method -sets fixed values)? - -=head1 SEE ALSO - -L, L, L, L, schema.html -from the base documentation. - -=head1 HISTORY - -$Log: svc_Common.pm,v $ -Revision 1.3 1999-03-25 13:31:29 ivan -added setdefault method (generalized setfixed method to setx method) - -Revision 1.2 1999/01/25 12:26:14 ivan -yet more mod_perl stuff - -Revision 1.1 1998/12/30 00:30:45 ivan -svc_ stuff is more properly OO - has a common superclass FS::svc_Common - - -=cut - -1; - diff --git a/site_perl/svc_acct.pm b/site_perl/svc_acct.pm deleted file mode 100644 index 9ae531a90..000000000 --- a/site_perl/svc_acct.pm +++ /dev/null @@ -1,514 +0,0 @@ -package FS::svc_acct; - -use strict; -use vars qw(@ISA $nossh_hack $conf $dir_prefix @shells - $shellmachine @saltset @pw_set); -use FS::Conf; -use FS::Record qw( qsearchs fields ); -use FS::svc_Common; -use FS::SSH qw(ssh); -use FS::part_svc; -use FS::svc_acct_pop; - -@ISA = qw( FS::svc_Common ); - -#ask FS::UID to run this stuff for us later -$FS::UID::callback{'FS::svc_acct'} = sub { - $conf = new FS::Conf; - $dir_prefix = $conf->config('home'); - @shells = $conf->config('shells'); - $shellmachine = $conf->config('shellmachine'); -}; - -@saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' ); -@pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' ); - -#not needed in 5.004 #srand($$|time); - -=head1 NAME - -FS::svc_acct - Object methods for svc_acct records - -=head1 SYNOPSIS - - use FS::svc_acct; - - $record = new FS::svc_acct \%hash; - $record = new FS::svc_acct { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - - $error = $record->suspend; - - $error = $record->unsuspend; - - $error = $record->cancel; - -=head1 DESCRIPTION - -An FS::svc_acct object represents an account. FS::svc_acct inherits from -FS::svc_Common. The following fields are currently supported: - -=over 4 - -=item svcnum - primary key (assigned automatcially for new accounts) - -=item username - -=item _password - generated if blank - -=item popnum - Point of presence (see L) - -=item uid - -=item gid - -=item finger - GECOS - -=item dir - set automatically if blank (and uid is not) - -=item shell - -=item quota - (unimplementd) - -=item slipip - IP address - -=item radius_I - I - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new account. To add the account to the database, see L<"insert">. - -=cut - -sub table { 'svc_acct'; } - -=item insert - -Adds this account to the database. If there is an error, returns the error, -otherwise returns false. - -The additional fields pkgnum and svcpart (see L) should be -defined. An FS::cust_svc record will be created and inserted. - -If the configuration value (see L) shellmachine exists, and the -username, uid, and dir fields are defined, the command - - useradd -d $dir -m -s $shell -u $uid $username - -is executed on shellmachine via ssh. This behaviour can be surpressed by -setting $FS::svc_acct::nossh_hack true. - -=cut - -sub insert { - my $self = shift; - my $error; - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - local $SIG{PIPE} = 'IGNORE'; - - $error = $self->check; - return $error if $error; - - return "Username ". $self->username. " in use" - if qsearchs( 'svc_acct', { 'username' => $self->username } ); - - my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } ); - return "Unkonwn svcpart" unless $part_svc; - return "uid in use" - if $part_svc->svc_acct__uid_flag ne 'F' - && qsearchs( 'svc_acct', { 'uid' => $self->uid } ) - && $self->username !~ /^(hyla)?fax$/ - ; - - $error = $self->SUPER::insert; - return $error if $error; - - my ( $username, $uid, $dir, $shell ) = ( - $self->username, - $self->uid, - $self->dir, - $self->shell, - ); - if ( $username - && $uid - && $dir - && $shellmachine - && ! $nossh_hack ) { - #one way - ssh("root\@$shellmachine", - "useradd -d $dir -m -s $shell -u $uid $username" - ); - #another way - #ssh("root\@$shellmachine","/bin/mkdir $dir; /bin/chmod 711 $dir; ". - # "/bin/cp -p /etc/skel/.* $dir 2>/dev/null; ". - # "/bin/cp -pR /etc/skel/Maildir $dir 2>/dev/null; ". - # "/bin/chown -R $uid $dir") unless $nossh_hack; - } - - ''; #no error -} - -=item delete - -Deletes this account from the database. If there is an error, returns the -error, otherwise returns false. - -The corresponding FS::cust_svc record will be deleted as well. - -If the configuration value (see L) shellmachine exists, the command: - - userdel $username - -is executed on shellmachine via ssh. This behaviour can be surpressed by -setting $FS::svc_acct::nossh_hack true. - -=cut - -sub delete { - my $self = shift; - my $error; - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - local $SIG{PIPE} = 'IGNORE'; - - $error = $self->SUPER::delete; - return $error if $error; - - my $username = $self->username; - if ( $username && $shellmachine && ! $nossh_hack ) { - ssh("root\@$shellmachine","userdel $username"); - } - - ''; -} - -=item replace OLD_RECORD - -Replaces OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -If the configuration value (see L) shellmachine exists, and the -dir field has changed, the command: - - [ -d $old_dir ] && ( - chmod u+t $old_dir; - umask 022; - mkdir $new_dir; - cd $old_dir; - find . -depth -print | cpio -pdm $new_dir; - chmod u-t $new_dir; - chown -R $uid.$gid $new_dir; - rm -rf $old_dir - ) - -is executed on shellmachine via ssh. This behaviour can be surpressed by -setting $FS::svc_acct::nossh_hack true. - -=cut - -sub replace { - my ( $new, $old ) = ( shift, shift ); - my $error; - - return "Username in use" - if $old->username ne $new->username && - qsearchs( 'svc_acct', { 'username' => $new->username } ); - - return "Can't change uid!" if $old->uid != $new->uid; - - #change homdir when we change username - $new->setfield('dir', '') if $old->username ne $new->username; - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - local $SIG{PIPE} = 'IGNORE'; - - $error = $new->SUPER::replace($old); - return $error if $error; - - my ( $old_dir, $new_dir ) = ( $old->getfield('dir'), $new->getfield('dir') ); - my ( $uid, $gid) = ( $new->getfield('uid'), $new->getfield('gid') ); - if ( $old_dir - && $new_dir - && $old_dir ne $new_dir - && ! $nossh_hack - ) { - ssh("root\@$shellmachine","[ -d $old_dir ] && ". - "( chmod u+t $old_dir; ". #turn off qmail delivery - "umask 022; mkdir $new_dir; cd $old_dir; ". - "find . -depth -print | cpio -pdm $new_dir; ". - "chmod u-t $new_dir; chown -R $uid.$gid $new_dir; ". - "rm -rf $old_dir". - ")" - ); - } - - ''; #no error -} - -=item suspend - -Suspends this account by prefixing *SUSPENDED* to the password. If there is an -error, returns the error, otherwise returns false. - -Called by the suspend method of FS::cust_pkg (see L). - -=cut - -sub suspend { - my $self = shift; - my %hash = $self->hash; - unless ( $hash{_password} =~ /^\*SUSPENDED\* / ) { - $hash{_password} = '*SUSPENDED* '.$hash{_password}; - my $new = new FS::svc_acct ( \%hash ); - $new->replace($self); - } else { - ''; #no error (already suspended) - } -} - -=item unsuspend - -Unsuspends this account by removing *SUSPENDED* from the password. If there is -an error, returns the error, otherwise returns false. - -Called by the unsuspend method of FS::cust_pkg (see L). - -=cut - -sub unsuspend { - my $self = shift; - my %hash = $self->hash; - if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) { - $hash{_password} = $1; - my $new = new FS::svc_acct ( \%hash ); - $new->replace($self); - } else { - ''; #no error (already unsuspended) - } -} - -=item cancel - -Just returns false (no error) for now. - -Called by the cancel method of FS::cust_pkg (see L). - -=item check - -Checks all fields to make sure this is a valid service. If there is an error, -returns the error, otherwise returns false. Called by the insert and replace -methods. - -Sets any fixed values; see L. - -=cut - -sub check { - my $self = shift; - - my($recref) = $self->hashref; - - my $x = $self->setfixed; - return $x unless ref($x); - my $part_svc = $x; - - my $ulen =$self->dbdef_table->column('username')->length; - $recref->{username} =~ /^([a-z0-9_\-]{2,$ulen})$/ - or return "Illegal username"; - $recref->{username} = $1; - $recref->{username} =~ /[a-z]/ or return "Illegal username"; - - $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum"; - $recref->{popnum} = $1; - return "Unkonwn popnum" unless - ! $recref->{popnum} || - qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } ); - - unless ( $part_svc->getfield('svc_acct__uid_flag') eq 'F' ) { - - $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid"; - $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1; - - $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid"; - $recref->{gid} = $1 eq '' ? $recref->{uid} : $1; - #not all systems use gid=uid - #you can set a fixed gid in part_svc - - return "Only root can have uid 0" - if $recref->{uid} == 0 && $recref->{username} ne 'root'; - - my($error); - return $error if $error=$self->ut_textn('finger'); - - $recref->{dir} =~ /^([\/\w\-]*)$/ - or return "Illegal directory"; - $recref->{dir} = $1 || - $dir_prefix . '/' . $recref->{username} - #$dir_prefix . '/' . substr($recref->{username},0,1). '/' . $recref->{username} - ; - - unless ( $recref->{username} eq 'sync' ) { - my($shell); - if ( $shell = (grep $_ eq $recref->{shell}, @shells)[0] ) { - $recref->{shell} = $shell; - } else { - return "Illegal shell \`". $self->shell. "\'; ". - $conf->dir. "/shells contains: @shells"; - } - } else { - $recref->{shell} = '/bin/sync'; - } - - $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota (unimplemented)"; - $recref->{quota} = $1; - - } else { - $recref->{gid} ne '' ? - return "Can't have gid without uid" : ( $recref->{gid}='' ); - $recref->{finger} ne '' ? - return "Can't have finger-name without uid" : ( $recref->{finger}='' ); - $recref->{dir} ne '' ? - return "Can't have directory without uid" : ( $recref->{dir}='' ); - $recref->{shell} ne '' ? - return "Can't have shell without uid" : ( $recref->{shell}='' ); - $recref->{quota} ne '' ? - return "Can't have quota without uid" : ( $recref->{quota}='' ); - } - - unless ( $part_svc->getfield('svc_acct__slipip_flag') eq 'F' ) { - unless ( $recref->{slipip} eq '0e0' ) { - $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/ - or return "Illegal slipip". $self->slipip; - $recref->{slipip} = $1; - } else { - $recref->{slipip} = '0e0'; - } - - } - - #arbitrary RADIUS stuff; allow ut_textn for now - foreach ( grep /^radius_/, fields('svc_acct') ) { - $self->ut_textn($_); - } - - #generate a password if it is blank - $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) ) - unless ( $recref->{_password} ); - - #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) { - if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,8})$/ ) { - $recref->{_password} = $1.$3; - #uncomment this to encrypt password immediately upon entry, or run - #bin/crypt_pw in cron to give new users a window during which their - #password is available to techs, for faxing, etc. (also be aware of - #radius issues!) - #$recref->{password} = $1. - # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))] - #; - } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/]{13,24})$/ ) { - $recref->{_password} = $1.$3; - } elsif ( $recref->{_password} eq '*' ) { - $recref->{_password} = '*'; - } else { - return "Illegal password"; - } - - ''; #no error -} - -=back - -=head1 VERSION - -$Id: svc_acct.pm,v 1.8 1999-07-29 08:47:26 ivan Exp $ - -=head1 BUGS - -The remote commands should be configurable. - -The bits which ssh should fork before doing so. - -The $recref stuff in sub check should be cleaned up. - -=head1 SEE ALSO - -L, L, L, L, -L, L, L, L, L, -schema.html from the base documentation. - -=head1 HISTORY - -ivan@voicenet.com 97-jul-16 - 21 - -rewrite (among other things, now know about part_svc) ivan@sisd.com 98-mar-8 - -Changed 'password' to '_password' because Pg6.3 reserves the password word - bmccane@maxbaud.net 98-apr-3 - -username length and shell no longer hardcoded ivan@sisd.com 98-jun-28 - -eww but needed: ignore uid duplicates for 'fax' and 'hylafax' -ivan@sisd.com 98-jun-29 - -$nossh_hack ivan@sisd.com 98-jul-13 - -protections against UID/GID of 0 for incorrectly-setup RDBMSs (also -in bin/svc_acct.export) ivan@sisd.com 98-jul-13 - -arbitrary radius attributes ivan@sisd.com 98-aug-13 - -/var/spool/freeside/conf/shellmachine ivan@sisd.com 98-aug-13 - -pod and FS::conf ivan@sisd.com 98-sep-22 - -$Log: svc_acct.pm,v $ -Revision 1.8 1999-07-29 08:47:26 ivan -more informative illegal shells error. - -Revision 1.7 1999/04/07 14:37:37 ivan -use FS::part_svc and FS::svc_acct_pop to avoid warnings - -Revision 1.6 1999/01/25 12:26:15 ivan -yet more mod_perl stuff - -Revision 1.5 1999/01/18 21:58:09 ivan -esthetic: eq and ne were used in a few places instead of == and != - -Revision 1.4 1998/12/30 00:30:45 ivan -svc_ stuff is more properly OO - has a common superclass FS::svc_Common - -Revision 1.2 1998/11/13 09:56:55 ivan -change configuration file layout to support multiple distinct databases (with -own set of config files, export, etc.) - - -=cut - -1; - diff --git a/site_perl/svc_acct_pop.pm b/site_perl/svc_acct_pop.pm deleted file mode 100644 index fe2b5f3ac..000000000 --- a/site_perl/svc_acct_pop.pm +++ /dev/null @@ -1,124 +0,0 @@ -package FS::svc_acct_pop; - -use strict; -use vars qw( @ISA ); -use FS::Record qw( qsearchs ); - -@ISA = qw( FS::Record ); - -=head1 NAME - -FS::svc_acct_pop - Object methods for svc_acct_pop records - -=head1 SYNOPSIS - - use FS::svc_acct_pop; - - $record = new FS::svc_acct_pop \%hash; - $record = new FS::svc_acct_pop { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::svc_acct object represents an point of presence. FS::svc_acct_pop -inherits from FS::Record. The following fields are currently supported: - -=over 4 - -=item popnum - primary key (assigned automatically for new accounts) - -=item city - -=item state - -=item ac - area code - -=item exch - exchange - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new point of presence (if only it were that easy!). To add the -point of presence to the database, see L<"insert">. - -=cut - -sub table { 'svc_acct_pop'; } - -=item insert - -Adds this point of presence to the database. If there is an error, returns the -error, otherwise returns false. - -=item delete - -Removes this point of presence from the database. - -=item replace OLD_RECORD - -Replaces OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -=item check - -Checks all fields to make sure this is a valid point of presence. If there is -an error, returns the error, otherwise returns false. Called by the insert -and replace methods. - -=cut - -sub check { - my $self = shift; - - $self->ut_numbern('popnum') - or $self->ut_text('city') - or $self->ut_text('state') - or $self->ut_number('ac') - or $self->ut_number('exch') - ; - -} - -=back - -=head1 VERSION - -$Id: svc_acct_pop.pm,v 1.2 1998-12-29 11:59:53 ivan Exp $ - -=head1 BUGS - -It should be renamed to part_pop. - -=head1 SEE ALSO - -L, L, schema.html from the base documentation. - -=head1 HISTORY - -Class dealing with pops - -ivan@sisd.com 98-mar-8 - -pod ivan@sisd.com 98-sep-23 - -$Log: svc_acct_pop.pm,v $ -Revision 1.2 1998-12-29 11:59:53 ivan -mostly properly OO, some work still to be done with svc_ stuff - - -=cut - -1; - diff --git a/site_perl/svc_acct_sm.pm b/site_perl/svc_acct_sm.pm deleted file mode 100644 index c757ab073..000000000 --- a/site_perl/svc_acct_sm.pm +++ /dev/null @@ -1,266 +0,0 @@ -package FS::svc_acct_sm; - -use strict; -use vars qw( @ISA $nossh_hack $conf $shellmachine @qmailmachines ); -use FS::Record qw( fields qsearch qsearchs ); -use FS::svc_Common; -use FS::cust_svc; -use FS::SSH qw(ssh); -use FS::Conf; -use FS::svc_acct; -use FS::svc_domain; - -@ISA = qw( FS::svc_Common ); - -#ask FS::UID to run this stuff for us later -$FS::UID::callback{'FS::svc_acct_sm'} = sub { - $conf = new FS::Conf; - $shellmachine = $conf->exists('qmailmachines') - ? $conf->config('shellmachine') - : ''; -}; - -=head1 NAME - -FS::svc_acct_sm - Object methods for svc_acct_sm records - -=head1 SYNOPSIS - - use FS::svc_acct_sm; - - $record = new FS::svc_acct_sm \%hash; - $record = new FS::svc_acct_sm { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - - $error = $record->suspend; - - $error = $record->unsuspend; - - $error = $record->cancel; - -=head1 DESCRIPTION - -An FS::svc_acct object represents a virtual mail alias. FS::svc_acct inherits -from FS::Record. The following fields are currently supported: - -=over 4 - -=item svcnum - primary key (assigned automatcially for new accounts) - -=item domsvc - svcnum of the virtual domain (see L) - -=item domuid - uid of the target account (see L) - -=item domuser - virtual username - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new virtual mail alias. To add the virtual mail alias to the -database, see L<"insert">. - -=cut - -sub table { 'svc_acct_sm'; } - -=item insert - -Adds this virtual mail alias to the database. If there is an error, returns -the error, otherwise returns false. - -The additional fields pkgnum and svcpart (see L) should be -defined. An FS::cust_svc record will be created and inserted. - -If the configuration values (see L) shellmachine and qmailmachines -exist, and domuser is `*' (meaning a catch-all mailbox), the command: - - [ -e $dir/.qmail-$qdomain-default ] || { - touch $dir/.qmail-$qdomain-default; - chown $uid:$gid $dir/.qmail-$qdomain-default; - } - -is executed on shellmachine via ssh (see L). -This behaviour can be surpressed by setting $FS::svc_acct_sm::nossh_hack true. - -=cut - -sub insert { - my $self = shift; - my $error; - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - local $SIG{PIPE} = 'IGNORE'; - - $error=$self->check; - return $error if $error; - - return "Domain username (domuser) in use for this domain (domsvc)" - if qsearchs('svc_acct_sm',{ 'domuser'=> $self->domuser, - 'domsvc' => $self->domsvc, - } ); - - return "First domain username (domuser) for domain (domsvc) must be " . - qq='*' (catch-all)!= - if $self->domuser ne '*' && - ! qsearch('svc_acct_sm',{ 'domsvc' => $self->domsvc } ); - - $error = $self->SUPER::insert; - return $error if $error; - - my $svc_domain = qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } ); - my $svc_acct = qsearchs( 'svc_acct', { 'uid' => $self->domuid } ); - my ( $uid, $gid, $dir, $domain ) = ( - $svc_acct->uid, - $svc_acct->gid, - $svc_acct->dir, - $svc_domain->domain, - ); - my $qdomain = $domain; - $qdomain =~ s/\./:/g; #see manpage for 'dot-qmail': EXTENSION ADDRESSES - ssh("root\@$shellmachine","[ -e $dir/.qmail-$qdomain-default ] || { touch $dir/.qmail-$qdomain-default; chown $uid:$gid $dir/.qmail-$qdomain-default; }") - if ( ! $nossh_hack && $shellmachine && $dir && $self->domuser eq '*' ); - - ''; #no error - -} - -=item delete - -Deletes this virtual mail alias from the database. If there is an error, -returns the error, otherwise returns false. - -The corresponding FS::cust_svc record will be deleted as well. - -=item replace OLD_RECORD - -Replaces OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -=cut - -sub replace { - my ( $new, $old ) = ( shift, shift ); - my $error; - - return "Domain username (domuser) in use for this domain (domsvc)" - if ( $old->domuser ne $new->domuser - || $old->domsvc != $new->domsvc - ) && qsearchs('svc_acct_sm',{ - 'domuser'=> $new->domuser, - 'domsvc' => $new->domsvc, - } ) - ; - - $new->SUPER::replace($old); - -} - -=item suspend - -Just returns false (no error) for now. - -Called by the suspend method of FS::cust_pkg (see L). - -=item unsuspend - -Just returns false (no error) for now. - -Called by the unsuspend method of FS::cust_pkg (see L). - -=item cancel - -Just returns false (no error) for now. - -Called by the cancel method of FS::cust_pkg (see L). - -=item check - -Checks all fields to make sure this is a valid virtual mail alias. If there is -an error, returns the error, otherwise returns false. Called by the insert and -replace methods. - -Sets any fixed values; see L. - -=cut - -sub check { - my $self = shift; - my $error; - - my $x = $self->setfixed; - return $x unless ref($x); - my $part_svc = $x; - - my($recref) = $self->hashref; - - $recref->{domuser} =~ /^(\*|[a-z0-9_\-]{2,32})$/ - or return "Illegal domain username (domuser)"; - $recref->{domuser} = $1; - - $recref->{domsvc} =~ /^(\d+)$/ or return "Illegal domsvc"; - $recref->{domsvc} = $1; - my($svc_domain); - return "Unknown domsvc" unless - $svc_domain=qsearchs('svc_domain',{'svcnum'=> $recref->{domsvc} } ); - - $recref->{domuid} =~ /^(\d+)$/ or return "Illegal uid"; - $recref->{domuid} = $1; - my($svc_acct); - return "Unknown uid" unless - $svc_acct=qsearchs('svc_acct',{'uid'=> $recref->{domuid} } ); - - ''; #no error -} - -=back - -=head1 VERSION - -$Id: svc_acct_sm.pm,v 1.7 1999-04-07 14:40:15 ivan Exp $ - -=head1 BUGS - -The remote commands should be configurable. - -The $recref stuff in sub check should be cleaned up. - -=head1 SEE ALSO - -L, L, L, L, L, -L, L, L, L, L, -schema.html from the base documentation. - -=head1 HISTORY - -ivan@voicenet.com 97-jul-16 - 21 - -rewrite ivan@sisd.com 98-mar-10 - -s/qsearchs/qsearch/ to eliminate warning ivan@sisd.com 98-apr-19 - -uses conf/shellmachine and has an nossh_hack ivan@sisd.com 98-jul-14 - -s/\./:/g in .qmail-domain:com ivan@sisd.com 98-aug-13 - -pod, FS::Conf, moved .qmail file from check to insert 98-sep-23 - -=cut - -1; - diff --git a/site_perl/svc_domain.pm b/site_perl/svc_domain.pm deleted file mode 100644 index 17fdd19d5..000000000 --- a/site_perl/svc_domain.pm +++ /dev/null @@ -1,458 +0,0 @@ -package FS::svc_domain; - -use strict; -use vars qw( @ISA $whois_hack $conf $mydomain $smtpmachine - $tech_contact $from $to @nameservers @nameserver_ips @template -); -use Carp; -use Mail::Internet; -use Mail::Header; -use Date::Format; -use Net::Whois; #0.24; -use FS::Record qw(fields qsearch qsearchs); -use FS::Conf; -use FS::svc_Common; -use FS::cust_svc; -use FS::svc_acct; -use FS::cust_pkg; -use FS::cust_main; - -@ISA = qw( FS::svc_Common ); - -#ask FS::UID to run this stuff for us later -$FS::UID::callback{'FS::domain'} = sub { - $conf = new FS::Conf; - - $mydomain = $conf->config('domain'); - $smtpmachine = $conf->config('smtpmachine'); - - my($internic)="/registries/internic"; - $tech_contact = $conf->config("$internic/tech_contact"); - $from = $conf->config("$internic/from"); - $to = $conf->config("$internic/to"); - my(@ns) = $conf->config("$internic/nameservers"); - @nameservers=map { - /^\s*\d+\.\d+\.\d+\.\d+\s+([^\s]+)\s*$/ - or die "Illegal line in $internic/nameservers"; - $1; - } @ns; - @nameserver_ips=map { - /^\s*(\d+\.\d+\.\d+\.\d+)\s+([^\s]+)\s*$/ - or die "Illegal line in $internic/nameservers!"; - $1; - } @ns; - @template = map { $_. "\n" } $conf->config("$internic/template"); - -}; - -=head1 NAME - -FS::svc_domain - Object methods for svc_domain records - -=head1 SYNOPSIS - - use FS::svc_domain; - - $record = new FS::svc_domain \%hash; - $record = new FS::svc_domain { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - - $error = $record->suspend; - - $error = $record->unsuspend; - - $error = $record->cancel; - -=head1 DESCRIPTION - -An FS::svc_domain object represents a domain. FS::svc_domain inherits from -FS::svc_Common. The following fields are currently supported: - -=over 4 - -=item svcnum - primary key (assigned automatically for new accounts) - -=item domain - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new domain. To add the domain to the database, see L<"insert">. - -=cut - -sub table { 'svc_domain'; } - -=item insert - -Adds this domain to the database. If there is an error, returns the error, -otherwise returns false. - -The additional fields I and I (see L) should be -defined. An FS::cust_svc record will be created and inserted. - -The additional field I should be set to I for new domains or I -for transfers. - -A registration or transfer email will be submitted unless -$FS::svc_domain::whois_hack is true. - -The additional field I can be used to manually set the admin contact -email address on this email. Otherwise, the svc_acct records for this package -(see L) are searched. If there is exactly one svc_acct record -in the same package, it is automatically used. Otherwise an error is returned. - -=cut - -sub insert { - my $self = shift; - my $error; - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - local $SIG{PIPE} = 'IGNORE'; - - $error = $self->check; - return $error if $error; - - return "Domain in use (here)" - if qsearchs( 'svc_domain', { 'domain' => $self->domain } ); - - my $whois = $self->whois; - return "Domain in use (see whois)" - if ( $self->action eq "N" && $whois ); - return "Domain not found (see whois)" - if ( $self->action eq "M" && ! $whois ); - - $error = $self->SUPER::insert; - return $error if $error; - - $self->submit_internic unless $whois_hack; - - ''; #no error -} - -=item delete - -Deletes this domain from the database. If there is an error, returns the -error, otherwise returns false. - -The corresponding FS::cust_svc record will be deleted as well. - -=item replace OLD_RECORD - -Replaces OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -=cut - -sub replace { - my ( $new, $old ) = ( shift, shift ); - my $error; - - return "Can't change domain - reorder." - if $old->getfield('domain') ne $new->getfield('domain'); - - $new->SUPER::replace($old); - -} - -=item suspend - -Just returns false (no error) for now. - -Called by the suspend method of FS::cust_pkg (see L). - -=item unsuspend - -Just returns false (no error) for now. - -Called by the unsuspend method of FS::cust_pkg (see L). - -=item cancel - -Just returns false (no error) for now. - -Called by the cancel method of FS::cust_pkg (see L). - -=item check - -Checks all fields to make sure this is a valid domain. If there is an error, -returns the error, otherwise returns false. Called by the insert and replace -methods. - -Sets any fixed values; see L. - -=cut - -sub check { - my $self = shift; - my $error; - - my $x = $self->setfixed; - return $x unless ref($x); - my $part_svc = $x; - - #hmm - my $pkgnum; - if ( $self->svcnum ) { - my $cust_svc = qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } ); - $pkgnum = $cust_svc->pkgnum; - } else { - $pkgnum = $self->pkgnum; - } - - my($recref) = $self->hashref; - - unless ( $whois_hack ) { - unless ( $self->email ) { #find out an email address - my @svc_acct; - foreach ( qsearch( 'cust_svc', { 'pkgnum' => $pkgnum } ) ) { - my $svc_acct = qsearchs( 'svc_acct', { 'svcnum' => $_->svcnum } ); - push @svc_acct, $svc_acct if $svc_acct; - } - - if ( scalar(@svc_acct) == 0 ) { - return "Must order an account in package ". $pkgnum. " first"; - } elsif ( scalar(@svc_acct) > 1 ) { - return "More than one account in package ". $pkgnum. ": specify admin contact email"; - } else { - $self->email($svc_acct[0]->username. '@'. $mydomain); - } - } - } - - #if ( $recref->{domain} =~ /^([\w\-\.]{1,22})\.(com|net|org|edu)$/ ) { - if ( $recref->{domain} =~ /^([\w\-]{1,22})\.(com|net|org|edu)$/ ) { - $recref->{domain} = "$1.$2"; - # hmmmmmmmm. - } elsif ( $whois_hack && $recref->{domain} =~ /^([\w\-\.]+)$/ ) { - $recref->{domain} = $1; - } else { - return "Illegal domain ". $recref->{domain}. - " (or unknown registry - try \$whois_hack)"; - } - - $recref->{action} =~ /^(M|N)$/ or return "Illegal action"; - $recref->{action} = $1; - - $self->ut_textn('purpose'); - -} - -=item whois - -Returns the Net::Whois object corresponding to this domain, or undef if -the domain is not found in whois. - -(If $FS::svc_domain::whois_hack is true, returns that in all cases instead.) - -=cut - -sub whois { - $whois_hack or new Net::Whois::Domain $_[0]->domain; -} - -=item _whois - -Depriciated. - -=cut - -sub _whois { - die "_whois depriciated"; -} - -=item submit_internic - -Submits a registration email for this domain. - -=cut - -sub submit_internic { - my $self = shift; - - my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } ); - return unless $cust_pkg; - my $cust_main = qsearchs( 'cust_main', { 'custnum' => $cust_pkg->custnum } ); - return unless $cust_main; - - my %subs = ( - 'action' => $self->action, - 'purpose' => $self->purpose, - 'domain' => $self->domain, - 'company' => $cust_main->company - || $cust_main->getfield('first'). ' '. - $cust_main->getfield('last') - , - 'city' => $cust_main->city, - 'state' => $cust_main->state, - 'zip' => $cust_main->zip, - 'country' => $cust_main->country, - 'last' => $cust_main->getfield('last'), - 'first' => $cust_main->getfield('first'), - 'daytime' => $cust_main->daytime, - 'fax' => $cust_main->fax, - 'email' => $self->email, - 'tech_contact' => $tech_contact, - 'primary' => shift @nameservers, - 'primary_ip' => shift @nameserver_ips, - ); - - #yuck - my @xtemplate = @template; - my @body; - my $line; - OLOOP: while ( defined( $line = shift @xtemplate ) ) { - - if ( $line =~ /^###LOOP###$/ ) { - my(@buffer); - LOADBUF: while ( defined( $line = shift @xtemplate ) ) { - last LOADBUF if ( $line =~ /^###ENDLOOP###$/ ); - push @buffer, $line; - } - my %lubs = ( - 'address' => $cust_main->address2 - ? [ $cust_main->address1, $cust_main->address2 ] - : [ $cust_main->address1 ] - , - 'secondary' => [ @nameservers ], - 'secondary_ip' => [ @nameserver_ips ], - ); - LOOP: while (1) { - my @xbuffer = @buffer; - SUBLOOP: while ( defined( $line = shift @xbuffer ) ) { - if ( $line =~ /###(\w+)###/ ) { - #last LOOP unless my($lub)=shift@{$lubs{$1}}; - next OLOOP unless my $lub = shift @{$lubs{$1}}; - $line =~ s/###(\w+)###/$lub/e; - redo SUBLOOP; - } else { - push @body, $line; - } - } #SUBLOOP - } #LOOP - - } - - if ( $line =~ /###(\w+)###/ ) { - #$line =~ s/###(\w+)###/$subs{$1}/eg; - $line =~ s/###(\w+)###/$subs{$1}/e; - redo OLOOP; - } else { - push @body, $line; - } - - } #OLOOP - - my $subject; - if ( $self->action eq "M" ) { - $subject = "MODIFY DOMAIN ". $self->domain; - } elsif ( $self->action eq "N" ) { - $subject = "NEW DOMAIN ". $self->domain; - } else { - croak "submit_internic called with action ". $self->action; - } - - $ENV{SMTPHOSTS} = $smtpmachine; - $ENV{MAILADDRESS} = $from; - my $header = Mail::Header->new( [ - "From: $from", - "To: $to", - "Sender: $from", - "Reply-To: $from", - "Date: ". time2str("%a, %d %b %Y %X %z", time), - "Subject: $subject", - ] ); - - my($msg)=Mail::Internet->new( - 'Header' => $header, - 'Body' => \@body, - ); - - $msg->smtpsend or die "Can't send registration email"; #die? warn? - -} - -=back - -=head1 VERSION - -$Id: svc_domain.pm,v 1.8 1999-08-03 07:43:33 ivan Exp $ - -=head1 BUGS - -All BIND/DNS fields should be included (and exported). - -Delete doesn't send a registration template. - -All registries should be supported. - -Should change action to a real field. - -The $recref stuff in sub check should be cleaned up. - -=head1 SEE ALSO - -L, L, L, L, -L, L, L, L, L, -L, schema.html from the base documentation, config.html from the -base documentation. - -=head1 HISTORY - -ivan@voicenet.com 97-jul-21 - -rewrite ivan@sisd.com 98-mar-10 - -add internic bits ivan@sisd.com 98-mar-14 - -Changed 'day' to 'daytime' because Pg6.3 reserves the day word - bmccane@maxbaud.net 98-apr-3 - -/var/spool/freeside/conf/registries/internic/, Mail::Internet, etc. -ivan@sisd.com 98-jul-17-19 - -pod, some FS::Conf (not complete) ivan@sisd.com 98-sep-23 - -$Log: svc_domain.pm,v $ -Revision 1.8 1999-08-03 07:43:33 ivan -use Net::Whois; - -Revision 1.7 1999/04/07 14:40:15 ivan -use all stuff that's qsearch'ed to avoid warnings - -Revision 1.6 1999/01/25 12:26:17 ivan -yet more mod_perl stuff - -Revision 1.5 1998/12/30 00:30:47 ivan -svc_ stuff is more properly OO - has a common superclass FS::svc_Common - -Revision 1.3 1998/11/13 09:56:57 ivan -change configuration file layout to support multiple distinct databases (with -own set of config files, export, etc.) - -Revision 1.2 1998/10/14 08:18:21 ivan -More informative error messages and better doc for admin contact email stuff - - -=cut - -1; - - diff --git a/site_perl/table_template-svc.pm b/site_perl/table_template-svc.pm deleted file mode 100644 index 40c9ed9b5..000000000 --- a/site_perl/table_template-svc.pm +++ /dev/null @@ -1,177 +0,0 @@ -package FS::svc_table; - -use strict; -use vars qw(@ISA); -#use FS::Record qw( qsearch qsearchs ); -use FS::svc_Common; -use FS::cust_svc; - -@ISA = qw(svc_Common); - -=head1 NAME - -FS::table_name - Object methods for table_name records - -=head1 SYNOPSIS - - use FS::table_name; - - $record = new FS::table_name \%hash; - $record = new FS::table_name { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - - $error = $record->suspend; - - $error = $record->unsuspend; - - $error = $record->cancel; - -=head1 DESCRIPTION - -An FS::table_name object represents an example. FS::table_name inherits from -FS::svc_Common. The following fields are currently supported: - -=over 4 - -=item field - description - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new example. To add the example to the database, see L<"insert">. - -Note that this stores the 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 table { 'table_name'; } - -=item insert - -Adds this record to the database. If there is an error, returns the error, -otherwise returns false. - -The additional fields pkgnum and svcpart (see L) should be -defined. An FS::cust_svc record will be created and inserted. - -=cut - -sub insert { - my $self = shift; - my $error; - - $error = $self->SUPER::insert; - return $error if $error; - - ''; -} - -=item delete - -Delete this record from the database. - -=cut - -sub delete { - my $self = shift; - my $error; - - $error = $self->SUPER::delete; - return $error if $error; - - ''; -} - - -=item replace OLD_RECORD - -Replaces the OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -=cut - -sub replace { - my ( $new, $old ) = ( shift, shift ); - my $error; - - $error = $new->SUPER::replace($old); - return $error if $error; - - ''; -} - -=item suspend - -Called by the suspend method of FS::cust_pkg (see L). - -=item unsuspend - -Called by the unsuspend method of FS::cust_pkg (see L). - -=item cancel - -Called by the cancel method of FS::cust_pkg (see L). - -=item check - -Checks all fields to make sure this is a valid example. If there is -an error, returns the error, otherwise returns false. Called by the insert -and repalce methods. - -=cut - -sub check { - my $self = shift; - - my $x = $self->setfixed; - return $x unless ref($x); - my $part_svc = $x; - - - ''; #no error -} - -=back - -=head1 VERSION - -$Id: table_template-svc.pm,v 1.4 1998-12-30 00:30:48 ivan Exp $ - -=head1 BUGS - -The author forgot to customize this manpage. - -=head1 SEE ALSO - -L, L, L, L, -L, schema.html from the base documentation. - -=head1 HISTORY - -ivan@voicenet.com 97-jul-21 - -$Log: table_template-svc.pm,v $ -Revision 1.4 1998-12-30 00:30:48 ivan -svc_ stuff is more properly OO - has a common superclass FS::svc_Common - -Revision 1.2 1998/11/15 04:33:01 ivan -updates for newest versoin - - -=cut - -1; - diff --git a/site_perl/table_template.pm b/site_perl/table_template.pm deleted file mode 100644 index 0173bc5cf..000000000 --- a/site_perl/table_template.pm +++ /dev/null @@ -1,134 +0,0 @@ -package FS::table_name; - -use strict; -use vars qw( @ISA ); -use FS::Record qw( qsearch qsearchs ); - -@ISA = qw(FS::Record); - -=head1 NAME - -FS::table_name - Object methods for table_name records - -=head1 SYNOPSIS - - use FS::table_name; - - $record = new FS::table_name \%hash; - $record = new FS::table_name { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::table_name object represents an example. FS::table_name inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item field - description - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Creates a new example. To add the example to the database, see L<"insert">. - -Note that this stores the 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 - -# the new method can be inherited from FS::Record, if a table method is defined - -sub table { 'table_name'; } - -=item insert - -Adds this record to the database. If there is an error, returns the error, -otherwise returns false. - -=cut - -# the insert method can be inherited from FS::Record - -=item delete - -Delete this record from the database. - -=cut - -# the delete method can be inherited from FS::Record - -=item replace OLD_RECORD - -Replaces the OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -=cut - -# the replace method can be inherited from FS::Record - -=item check - -Checks all fields to make sure this is a valid example. If there is -an error, returns the error, otherwise returns false. Called by the insert -and replace methods. - -=cut - -# the check method should currently be supplied - FS::Record contains some -# data checking routines - -sub check { - my $self = shift; - - ''; #no error -} - -=back - -=head1 VERSION - -$Id: table_template.pm,v 1.4 1998-12-29 11:59:57 ivan Exp $ - -=head1 BUGS - -The author forgot to customize this manpage. - -=head1 SEE ALSO - -L, schema.html from the base documentation. - -=head1 HISTORY - -ivan@voicenet.com 97-jul-1 - -added hfields -ivan@sisd.com 97-nov-13 - -$Log: table_template.pm,v $ -Revision 1.4 1998-12-29 11:59:57 ivan -mostly properly OO, some work still to be done with svc_ stuff - -Revision 1.3 1998/11/15 04:33:00 ivan -updates for newest versoin - -Revision 1.2 1998/11/15 03:48:49 ivan -update for current version - - -=cut - -1; - diff --git a/site_perl/type_pkgs.pm b/site_perl/type_pkgs.pm deleted file mode 100644 index e19345e7c..000000000 --- a/site_perl/type_pkgs.pm +++ /dev/null @@ -1,128 +0,0 @@ -package FS::type_pkgs; - -use strict; -use vars qw( @ISA ); -use FS::Record qw( qsearchs ); -use FS::agent_type; -use FS::part_pkg; - -@ISA = qw( FS::Record ); - -=head1 NAME - -FS::type_pkgs - Object methods for type_pkgs records - -=head1 SYNOPSIS - - use FS::type_pkgs; - - $record = new FS::type_pkgs \%hash; - $record = new FS::type_pkgs { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::type_pkgs record links an agent type (see L) to a -billing item definition (see L). FS::type_pkgs inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item typenum - Agent type, see L - -=item pkgpart - Billing item definition, see L - -=back - -=head1 METHODS - -=over 4 - -=item new HASHREF - -Create a new record. To add the record to the database, see L<"insert">. - -=cut - -sub table { 'type_pkgs'; } - -=item insert - -Adds this record to the database. If there is an error, returns the error, -otherwise returns false. - -=item delete - -Deletes this record from the database. If there is an error, returns the -error, otherwise returns false. - -=item replace OLD_RECORD - -Replaces OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -=item check - -Checks all fields to make sure this is a valid record. If there is an error, -returns the error, otherwise returns false. Called by the insert and replace -methods. - -=cut - -sub check { - my $self = shift; - - my $error = - $self->ut_number('typenum') - || $self->ut_number('pkgpart') - ; - return $error if $error; - - return "Unknown typenum" - unless qsearchs( 'agent_type', { 'typenum' => $self->typenum } ); - - return "Unknown pkgpart" - unless qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } ); - - ''; #no error -} - -=back - -=head1 VERSION - -$Id: type_pkgs.pm,v 1.2 1998-12-29 11:59:58 ivan Exp $ - -=head1 BUGS - -=head1 SEE ALSO - -L, L, L, schema.html from the base -documentation. - -=head1 HISTORY - -Defines the relation between agent types and pkgparts -(Which pkgparts can the different [types of] agents sell?) - -ivan@sisd.com 97-nov-13 - -change to ut_ FS::Record, fixed bugs -ivan@sisd.com 97-dec-10 - -$Log: type_pkgs.pm,v $ -Revision 1.2 1998-12-29 11:59:58 ivan -mostly properly OO, some work still to be done with svc_ stuff - - -=cut - -1; - -- 2.11.0