diff options
Diffstat (limited to 'site_perl')
37 files changed, 3796 insertions, 2290 deletions
diff --git a/site_perl/CGI.pm b/site_perl/CGI.pm index d2ed52122..723d7f4ec 100644 --- a/site_perl/CGI.pm +++ b/site_perl/CGI.pm @@ -3,11 +3,13 @@ package FS::CGI; use strict; use vars qw(@EXPORT_OK @ISA); use Exporter; -use CGI::Base; +use CGI; +use URI::URL; use CGI::Carp qw(fatalsToBrowser); +use FS::UID; @ISA = qw(Exporter); -@EXPORT_OK = qw(header menubar idiot eidiot); +@EXPORT_OK = qw(header menubar idiot eidiot popurl table itable ntable); =head1 NAME @@ -15,7 +17,7 @@ FS::CGI - Subroutines for the web interface =head1 SYNOPSIS - use FS::CGI qw(header menubar idiot eidiot); + use FS::CGI qw(header menubar idiot eidiot popurl); print header( 'Title', '' ); print header( 'Title', menubar('item', 'URL', ... ) ); @@ -23,6 +25,9 @@ FS::CGI - Subroutines for the web interface 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. @@ -40,22 +45,21 @@ Returns an HTML header. sub header { my($title,$menubar)=@_; - <<END; + my $x = <<END; <HTML> <HEAD> <TITLE> $title </TITLE> </HEAD> - <BODY> - <CENTER> - <H1> + <BODY BGCOLOR="#e8e8e8"> + <FONT SIZE=7> $title - </H1> - $menubar - </CENTER> - <HR> + </FONT> + <BR><BR> END + $x .= $menubar. "<BR><BR>" if $menubar; + $x; } =item menubar ITEM, URL, ... @@ -75,13 +79,22 @@ sub menubar { #$menubar=menubar('Main Menu', '../', 'Item', 'url', ... ); =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)=@_; - CGI::Base::SendHeaders(); + my($cgi)=FS::UID::cgi; + if ( $cgi->isa('CGI::Base') ) { + no strict 'subs'; + &CGI::Base::SendHeaders; + } else { + print $cgi->header( '-expires' => 'now' ); + } print <<END; <HTML> <HEAD> @@ -93,7 +106,6 @@ sub idiot { </CENTER> Your request could not be processed because of the following error: <P><B>$error</B> - <P>Hit the <I>Back</I> button in your web browser, correct this mistake, and try again. </BODY> </HTML> END @@ -102,15 +114,84 @@ 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!<TABLE BGCOLOR="$col" BORDER=1 WIDTH="100%">!; + } else { + "<TABLE BORDER=1>"; + } +} + +=item itable + +Returns HTML tag for beginning an (invisible) table. + +=cut + +sub itable { + my $col = shift; + my $cellspacing = shift || 0; + if ( $col ) { + qq!<TABLE BGCOLOR="$col" BORDER=0 CELLSPACING=$cellspacing WIDTH="100%">!; + } else { + qq!<TABLE BORDER=0 CELLSPACING=$cellspacing WIDTH="100%">!; + } +} + +=item ntable + +This is getting silly. + +=cut + +sub ntable { + my $col = shift; + my $cellspacing = shift || 0; + if ( $col ) { + qq!<TABLE BGCOLOR="$col" BORDER=0 CELLSPACING=$cellspacing>!; + } else { + "<TABLE BORDER>"; + } + +} + =back =head1 BUGS @@ -119,11 +200,9 @@ Not OO. Not complete. -Uses CGI-modules instead of CGI.pm - =head1 SEE ALSO -L<CGI::Base> +L<CGI>, L<CGI::Base> =head1 HISTORY @@ -136,6 +215,45 @@ lose the background, eidiot ivan@sisd.com 98-sep-2 pod ivan@sisd.com 98-sep-12 +$Log: CGI.pm,v $ +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 index d3ef307c0..9cc0d900e 100644 --- a/site_perl/Conf.pm +++ b/site_perl/Conf.pm @@ -3,8 +3,6 @@ package FS::Conf; use vars qw($default_dir); use IO::File; -$default_dir='/var/spool/freeside/conf'; - =head1 NAME FS::Conf - Read access to Freeside configuration values @@ -13,8 +11,10 @@ FS::Conf - Read access to Freeside configuration values use FS::Conf; + $conf = new FS::Conf "/config/directory"; + + $FS::Conf::default_dir = "/config/directory"; $conf = new FS::Conf; - $conf = new FS::Conf "/non/standard/config/directory"; $dir = $conf->dir; @@ -33,8 +33,8 @@ but this may change in the future. =item new [ DIRECTORY ] -Create a new configuration object. Optionally, a non-default directory may -be specified. +Create a new configuration object. A directory arguement is required if +$FS::Conf::default_dir has not been set. =cut @@ -53,7 +53,12 @@ Returns the directory. sub dir { my($self) = @_; - $self->{dir}; + 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 @@ -94,8 +99,6 @@ sub exists { =head1 BUGS -The option to specify a non-default directory should probably be removed. - Write access (with locking) should be implemented. =head1 SEE ALSO @@ -108,6 +111,14 @@ Ivan Kohler <ivan@sisd.com> 98-sep-6 sub exists forgot to fetch $dir ivan@sisd.com 98-sep-27 +$Log: Conf.pm,v $ +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 index 5eb596fad..7fdcaaf6f 100644 --- a/site_perl/Invoice.pm +++ b/site_perl/Invoice.pm @@ -6,7 +6,7 @@ use FS::cust_bill; @ISA = qw(FS::cust_bill); -#warn "FS::Invoice depriciated\n"; +warn "FS::Invoice depriciated\n"; =head1 NAME @@ -14,7 +14,7 @@ FS::Invoice - Legacy stub =head1 SYNOPSIS -The functioanlity of FS::invoice has been integrated in FS::cust_bill. +The functionality of FS::Invoice has been integrated in FS::cust_bill. =head1 HISTORY diff --git a/site_perl/Record.pm b/site_perl/Record.pm index 9b308508a..6496d3ce5 100644 --- a/site_perl/Record.pm +++ b/site_perl/Record.pm @@ -4,7 +4,7 @@ use strict; use vars qw($dbdef_file $dbdef $setup_hack $AUTOLOAD @ISA @EXPORT_OK); use subs qw(reload_dbdef); use Exporter; -use Carp; +use Carp qw(carp cluck croak confess); use File::CounterFile; use FS::UID qw(dbh checkruid swapuid getotaker datasrc); use FS::dbdef; @@ -12,11 +12,12 @@ use FS::dbdef; @ISA = qw(Exporter); @EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef); -$File::CounterFile::DEFAULT_DIR = "/var/spool/freeside/counters" ; - -$dbdef_file = "/var/spool/freeside/dbdef.". datasrc; - -reload_dbdef unless $setup_hack; +#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 @@ -25,7 +26,7 @@ FS::Record - Database record objects =head1 SYNOPSIS use FS::Record; - use FS::Record qw(dbh fields hfields qsearch qsearchs dbdef); + use FS::Record qw(dbh fields qsearch qsearchs dbdef); $record = new FS::Record 'table', \%hash; $record = new FS::Record 'table', { 'column' => 'value', ... }; @@ -50,11 +51,14 @@ FS::Record - Database record objects $hashref = $record->hashref; - $error = $record->add; + $error = $record->insert; + #$error = $record->add; #depriciated - $error = $record->del; + $error = $record->delete; + #$error = $record->del; #depriciated - $error = $new_record->rep($old_record); + $error = $new_record->replace($old_record); + #$error = $new_record->rep($old_record); #depriciated $value = $record->unique('column'); @@ -79,7 +83,8 @@ FS::Record - Database record objects $fields = hfields('table'); if ( $fields->{Field} ) { # etc. - @fields = fields 'table'; + @fields = fields 'table'; #as a subroutine + @fields = $record->fields; #as a method call =head1 DESCRIPTION @@ -88,75 +93,69 @@ FS::Record - Database record objects implemented on top of DBI. FS::Record is intended as a base class for table-specific classes to inherit from, i.e. FS::cust_main. -=head1 METHODS +=head1 CONSTRUCTORS =over 4 -=item new TABLE, HASHREF +=item new [ TABLE, ] HASHREF Creates a new record. It doesn't store it in the database, though. See -L<"add"> for that. +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<hash> method. +TABLE can only be omitted when a dervived class overrides the table method. + =cut sub new { - my($proto,$table,$hashref) = @_; - confess "Second arguement to FS::Record->new is not a HASH ref: ", - ref($hashref), " ", $hashref, "\n" - unless ref($hashref) eq 'HASH'; #bad practice? + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + bless ($self, $class); - #check to make sure $table exists? (ask dbdef) + $self->{'Table'} = shift unless defined ( $self->table ); - foreach my $field ( FS::Record::fields $table ) { - $hashref->{$field}='' unless defined $hashref->{$field}; - } + my $hashref = $self->{'Hash'} = shift; - # mySQL must rtrim the inbound text strings or store them z-terminated - # I simulate this for Postgres below - # Turned off in favor of ChopBlanks in UID.pm (see man DBI) - #if (datasrc =~ m/Pg/) - #{ - # foreach my $index (keys %$hashref) - # { - # $$hashref{$index} = unpack("A255", $$hashref{$index}) - # if ($$hashref{$index} =~ m/ $/) ; - # } - #} - - foreach my $column (keys %{$hashref}) { - #trim the '$' from money fields for Pg (beong HERE?) + 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/ - && $dbdef->table($table)->column($column)->type eq 'money' ) { - ${$hashref}{$column} =~ s/^\$//; + && $self->dbdef_table->column($field)->type eq 'money' ) { + ${$hashref}{$field} =~ s/^\$//; + ${$hashref}{$field} =~ s/\,//; } - #foreach my $column ( grep $dbdef->table($table)->column($_)->type eq 'money', keys %{$hashref} ) { - # ${$hashref}{$column} =~ s/^\$//; - #} } - my $class = ref($proto) || $proto; - my $self = { 'Table' => $table, - 'Hash' => $hashref, - }; + $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::Record objects. +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 -# Usage: @records = &FS::Search::qsearch($table,\%hash); -# Each element of @records is a FS::Record object. sub qsearch { my($table,$record) = @_; my($dbh) = dbh; @@ -166,36 +165,54 @@ sub qsearch { my($sth); my($statement) = "SELECT * FROM $table". ( @fields ? " WHERE ". join(' AND ', - map("$_ = ". _quote($record->{$_},$table,$_), @fields) - ) - : '' + 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; - map { - new FS::Record ($table,$sth->fetchrow_hashref); - } ( 1 .. $sth->execute ); + 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 -Searches the database for a record matching (at least) the key/value pairs -in HASHREF, and returns the record found as an FS::Record object. If more than -one record matches, it B<carp>s but returns the first. If this happens, you -either made a logic error in asking for a single item, or your data is -corrupted. +Same as qsearch, except that if more than one record matches, it B<carp>s but +returns the first. If this happens, you either made a logic error in asking +for a single item, or your data is corrupted. =cut sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash); my(@result) = qsearch(@_); - carp "Multiple records in scalar search!" if scalar(@result) > 1; + 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. @@ -203,7 +220,8 @@ Returns the table name. =cut sub table { - my($self) = @_; +# cluck "warning: FS::Record::table depriciated; supply one in subclass!"; + my $self = shift; $self -> {'Table'}; } @@ -235,7 +253,8 @@ sub get { } } sub getfield { - get(@_); + my $self = shift; + $self->get(@_); } =item set, setfield COLUMN, VALUE @@ -249,7 +268,8 @@ sub set { $self->{'Hash'}->{$field} = $value; } sub setfield { - set(@_); + my $self = shift; + $self->set(@_); } =item AUTLOADED METHODS @@ -297,85 +317,98 @@ sub hashref { $self->{'Hash'}; } -=item add +=item insert -Adds this record to the database. If there is an error, returns the error, +Inserts this record to the database. If there is an error, returns the error, otherwise returns false. =cut -sub add { - my($self) = @_; - my($dbh)=dbh; - my($table)=$self->table; +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 ( $dbdef->table($table)->unique->singles ) { + foreach ( $self->dbdef_table->unique->singles ) { $self->unique($_) unless $self->getfield($_); } #and also the primary key - my($primary_key)=$dbdef->table($table)->primary_key; + my $primary_key = $self->dbdef_table->primary_key; $self->unique($primary_key) if $primary_key && ! $self->getfield($primary_key); - my (@fields) = + my @fields = grep defined($self->getfield($_)) && $self->getfield($_) ne "", - fields($table) + $self->fields ; - my($sth); - my($statement)="INSERT INTO $table ( ". + my $statement = "INSERT INTO ". $self->table. " ( ". join(', ',@fields ). ") VALUES (". - join(', ',map(_quote($self->getfield($_),$table,$_), @fields)). + join(', ',map(_quote($self->getfield($_),$self->table,$_), @fields)). ")" ; - $sth = $dbh->prepare($statement) or return $dbh->errstr; + 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 del +=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 del { - my($self) = @_; - my($dbh)=dbh; - my($table)=$self->table; +sub delete { + my $self = shift; - my($sth); - my($statement)="DELETE FROM $table WHERE ". join(' AND ', + my($statement)="DELETE FROM ". $self->table. " WHERE ". join(' AND ', map { $self->getfield($_) eq '' - ? "$_ IS NULL" - : "$_ = ". _quote($self->getfield($_),$table,$_) - } ( $dbdef->table($table)->primary_key ) - ? ($dbdef->table($table)->primary_key) - : fields($table) + #? "( $_ 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 ); - $sth = $dbh->prepare($statement) or return $dbh->errstr; + 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); - $rc=$sth->execute or return $sth->errstr; + 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! @@ -383,63 +416,97 @@ sub del { ''; } -=item rep OLD_RECORD +=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 rep { - my($new,$old)=@_; - my($dbh)=dbh; - my($table)=$old->table; - my(@fields)=fields($table); - my(@diff)=grep $new->getfield($_) ne $old->getfield($_), @fields; +sub replace { + my ( $new, $old ) = ( shift, shift ); - if ( scalar(@diff) == 0 ) { - carp "Records identical"; + 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 $table; + return "Records not in same table!" unless $new->table eq $old->table; - my($sth); - my($statement)="UPDATE $table SET ". join(', ', + 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($_),$table,$_) + "$_ = ". _quote($new->getfield($_),$old->table,$_) } @diff ). ' WHERE '. join(' AND ', map { $old->getfield($_) eq '' - ? "$_ IS NULL" - : "$_ = ". _quote($old->getfield($_),$table,$_) -# } @fields -# } ( primary_key($table) ? (primary_key($table)) : @fields ) - } ( $dbdef->table($table)->primary_key - ? ($dbdef->table($table)->primary_key) - : @fields - ) + #? "( $_ IS NULL OR $_ = \"\" )" + ? ( datasrc =~ m/Pg/ + ? "$_ IS NULL" + : "( $_ IS NULL OR $_ = \"\" )" + ) + : "$_ = ". _quote($old->getfield($_),$old->table,$_) + } ( $primary_key ? ( $primary_key ) : $old->fields ) ) ; - #warn $statement; - $sth = $dbh->prepare($statement) or return $dbh->errstr; + 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); - $rc=$sth->execute or return $sth->errstr; + 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 { + croak "FS::Record::check not implemented; supply one in subclass!"; +} + =item unique COLUMN Replaces COLUMN in record with a unique number. Called by the B<add> method @@ -495,7 +562,7 @@ sub ut_float { $self->getfield($field) =~ /^(\d+)$/ || $self->getfield($field) =~ /^(\d+\.\d+e\d+)$/ || $self->getfield($field) =~ /^(\d+e\d+)$/) - or return "Illegal or empty (float) $field!"; + or return "Illegal or empty (float) $field: ". $self->getfield($field); $self->setfield($field,$1); ''; } @@ -510,7 +577,7 @@ is an error, returns the error, otherwise returns false. sub ut_number { my($self,$field)=@_; $self->getfield($field) =~ /^(\d+)$/ - or return "Illegal or empty (numeric) $field!"; + or return "Illegal or empty (numeric) $field: ". $self->getfield($field); $self->setfield($field,$1); ''; } @@ -525,7 +592,7 @@ an error, returns the error, otherwise returns false. sub ut_numbern { my($self,$field)=@_; $self->getfield($field) =~ /^(\d*)$/ - or return "Illegal (numeric) $field!"; + or return "Illegal (numeric) $field: ". $self->getfield($field); $self->setfield($field,$1); ''; } @@ -539,9 +606,11 @@ is an error, returns the error, otherwise returns false. 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->setfield($field,"$1$2$3" || 0); + or return "Illegal (money) $field: ". $self->getfield($field); + #$self->setfield($field, "$1$2$3" || 0); + $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0); ''; } @@ -557,7 +626,7 @@ false. sub ut_text { my($self,$field)=@_; $self->getfield($field) =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/]+)$/ - or return "Illegal or empty (text) $field"; + or return "Illegal or empty (text) $field: ". $self->getfield($field); $self->setfield($field,$1); ''; } @@ -573,7 +642,7 @@ May be null. If there is an error, returns the error, otherwise returns false. sub ut_textn { my($self,$field)=@_; $self->getfield($field) =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/]*)$/ - or return "Illegal (text) $field"; + or return "Illegal (text) $field: ". $self->getfield($field); $self->setfield($field,$1); ''; } @@ -588,7 +657,8 @@ an error, returns the error, otherwise returns false. sub ut_alpha { my($self,$field)=@_; $self->getfield($field) =~ /^(\w+)$/ - or return "Illegal or empty (alphanumeric) $field!"; + or return "Illegal or empty (alphanumeric) $field: ". + $self->getfield($field); $self->setfield($field,$1); ''; } @@ -603,7 +673,7 @@ error, returns the error, otherwise returns false. sub ut_alphan { my($self,$field)=@_; $self->getfield($field) =~ /^(\w*)$/ - or return "Illegal (alphanumeric) $field!"; + or return "Illegal (alphanumeric) $field: ". $self->getfield($field); $self->setfield($field,$1); ''; } @@ -623,7 +693,7 @@ sub ut_phonen { } else { $phonen =~ s/\D//g; $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/ - or return "Illegal (phone) $field!"; + or return "Illegal (phone) $field: ". $self->getfield($field); $phonen = "$1-$2-$3"; $phonen .= " x$4" if $4; $self->setfield($field,$phonen); @@ -639,11 +709,35 @@ Untaints arbitrary data. Be careful. sub ut_anything { my($self,$field)=@_; - $self->getfield($field) =~ /^(.*)$/ or return "Illegal $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<dbdef_table>). + +=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 @@ -700,7 +794,7 @@ It returns a hash-type list with the fields of this record's table set true. =cut sub hfields { - carp "hfields is depriciated"; + carp "warning: hfields is depriciated"; my($table)=@_; my(%hash); foreach (fields($table)) { @@ -709,23 +803,6 @@ sub hfields { \%hash; } -=item fields TABLE - -This returns a list of the columns in this record's table -(See L<dbdef_table>). - -=cut - -# Usage: @fields = fields($table); -sub fields { - my($table) = @_; - #my(@fields) = $dbdef->table($table)->columns; - croak "Usage: \@fields = fields(\$table)" unless $table; - my($table_obj) = $dbdef->table($table); - croak "Unknown table $table" unless $table_obj; - $table_obj->columns; -} - #sub _dump { # my($self)=@_; # join("\n", map { @@ -746,6 +823,10 @@ sub fields { =back +=head1 VERSION + +$Id: Record.pm,v 1.16 1999-04-10 07:03:38 ivan Exp $ + =head1 BUGS This module should probably be renamed, since much of the functionality is @@ -768,7 +849,7 @@ The ut_ methods should ask the dbdef for a default length. ut_sqltype (like ut_varchar) should all be defined -A fallback check method should be provided with uses the dbdef. +A fallback check method should be provided whith uses the dbdef. The ut_money method assumes money has two decimal digits. @@ -780,6 +861,9 @@ 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<FS::dbdef>, L<FS::UID>, L<DBI> @@ -862,6 +946,53 @@ 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.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/UI/Base.pm b/site_perl/UI/Base.pm new file mode 100644 index 000000000..38087f6c8 --- /dev/null +++ b/site_perl/UI/Base.pm @@ -0,0 +1,191 @@ +package FS::UI::Base; + +use strict; +use vars qw ( @ISA ); +use FS::Record qw( fields qsearch ); + +@ISA = ( $FS::UI::Base::_lock ); + +=head1 NAME + +FS::UI::Base - Base class for all user-interface objects + +=head1 SYNOPSIS + + use FS::UI::SomeInterface; + use FS::UI::some_table; + + $interface = new FS::UI::some_table; + + $error = $interface->browse; + $error = $interface->search; + $error = $interface->view; + $error = $interface->edit; + $error = $interface->process; + +=head1 DESCRIPTION + +An FS::UI::Base object represents a user interface object. FS::UI::Base +is intended as a base class for table-specfic classes to inherit from, i.e. +FS::UI::cust_main. The simplest case, which will provide a default UI for your +new table, is as follows: + + package FS::UI::table_name; + use vars qw ( @ISA ); + use FS::UI::Base; + @ISA = qw( FS::UI::Base ); + sub db_table { 'table_name'; } + +Currently available interfaces are: + FS::UI::Gtk, an X-Windows UI implemented using the Gtk+ toolkit + FS::UI::CGI, a web interface implemented using CGI.pm, etc. + +=head1 METHODS + +=over 4 + +=item new + +=cut + +=item browse + +=cut + +sub browse { + my $self = shift; + + my @fields = $self->list_fields; + + #begin browse-specific stuff + + $self->title( "Browse ". $self->db_names ) unless $self->title; + my @records = qsearch ( $self->db_table, {} ); + + #end browse-specific stuff + + $self->addwidget ( new FS::UI::_Text ( $self->db_description ) ); + + my @header = $self->list_header; + my @headerspan = $self->list_headerspan; + my %callback = $self->db_callback; + + my $columns; + + my $table = new FS::UI::_Tableborder ( + 'rows' => 1 + scalar(@records), + 'columns' => $columns || scalar(@fields), + ); + + my $c = 0; + foreach my $header ( @header ) { + my $headerspan = shift(@headerspan) || 1; + $table->attach( + 0, $c, new FS::UI::_Text ( $header ), 1, $headerspan + ); + $c += $headerspan; + } + + my $r = 1; + + foreach my $record ( @records ) { + $c = 0; + foreach my $field ( @fields ) { + my $value = $record->getfield($field); + my $widget; + if ( $callback{$field} ) { + $widget = &{ $callback{$field} }( $value, $record ); + } else { + $widget = new FS::UI::_Text ( $value ); + } + $table->attach( $r, $c++, $widget, 1, 1 ); + } + $r++; + } + + $self->addwidget( $table ); + + $self->activate; + +} + +=item title + +=cut + +sub title { + my $self = shift; + my $value = shift; + if ( defined($value) ) { + $self->{'title'} = $value; + } else { + $self->{'title'}; + } +} + +=item addwidget + +=cut + +sub addwidget { + my $self = shift; + my $widget = shift; + push @{ $self->{'Widgets'} }, $widget; +} + +#fallback methods + +sub db_description {} + +sub db_name {} + +sub db_names { + my $self = shift; + $self->db_name. 's'; +} + +sub list_fields { + my $self = shift; + fields( $self->db_table ); +} + +sub list_header { + my $self = shift; + $self->list_fields +} + +sub list_headerspan { + my $self = shift; + map 1, $self->list_header; +} + +sub db_callback {} + +=back + +=head1 VERSION + +$Id: Base.pm,v 1.1 1999-01-20 09:30:36 ivan Exp $ + +=head1 BUGS + +This documentation is incomplete. + +There should be some sort of per-(freeside)-user preferences and the ability +for specific FS::UI:: modules to put their own values there as well. + +=head1 SEE ALSO + +L<FS::UI::Gtk>, L<FS::UI::CGI> + +=head1 HISTORY + +$Log: Base.pm,v $ +Revision 1.1 1999-01-20 09:30:36 ivan +skeletal cross-UI UI code. + + +=cut + +1; + diff --git a/site_perl/UI/CGI.pm b/site_perl/UI/CGI.pm new file mode 100644 index 000000000..e02e3d35a --- /dev/null +++ b/site_perl/UI/CGI.pm @@ -0,0 +1,236 @@ +package FS::UI::CGI; + +use strict; +use CGI; +#use CGI::Switch; #when FS::UID user and preference callback stuff is fixed +use CGI::Carp qw(fatalsToBrowser); +use HTML::Table; +use FS::UID qw(adminsuidsetup); +#use FS::Record qw( qsearch fields ); + +die "Can't initialize CGI interface; $FS::UI::Base::_lock used" + if $FS::UI::Base::_lock; +$FS::UI::Base::_lock = "FS::UI::CGI"; + +=head1 NAME + +FS::UI::CGI - Base class for CGI user-interface objects + +=head1 SYNOPSIS + + use FS::UI::CGI; + use FS::UI::some_table; + + $interface = new FS::UI::some_table; + + $error = $interface->browse; + $error = $interface->search; + $error = $interface->view; + $error = $interface->edit; + $error = $interface->process; + +=head1 DESCRIPTION + +An FS::UI::CGI object represents a CGI interface object. + +=head1 METHODS + +=over 4 + +=item new + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = { @_ }; + + $self->{'_cgi'} = new CGI; + $self->{'_user'} = $self->{'_cgi'}->remote_user; + $self->{'_dbh'} = FS::UID::adminsuidsetup $self->{'_user'}; + + bless ( $self, $class); +} + +sub activate { + my $self = shift; + print $self->_header, + join ( "<BR>", map $_->sprint, @{ $self->{'Widgets'} } ), + $self->_footer, + ; +} + +=item _header + +=cut + +sub _header { + my $self = shift; + my $cgi = $self->{'_cgi'}; + + $cgi->header( '-expires' => 'now' ), '<HTML>', + '<HEAD><TITLE>', $self->title, '</TITLE></HEAD>', + '<BODY BGCOLOR="#ffffff">', + '<FONT COLOR="#ff0000" SIZE=7>', $self->title, '</FONT><BR><BR>', + ; +} + +=item _footer + +=cut + +sub _footer { + "</BODY></HTML>"; +} + +=item interface + +Returns the string `CGI'. Useful for the author of a table-specific UI class +to conditionally specify certain behaviour. + +=cut + +sub interface { 'CGI'; } + +=back + +=cut + +package FS::UI::_Widget; + +use vars qw( $AUTOLOAD ); + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = { @_ }; + bless ( $self, $class ); +} + +sub AUTOLOAD { + my $self = shift; + my $value = shift; + my($field)=$AUTOLOAD; + $field =~ s/.*://; + if ( defined($value) ) { + $self->{$field} = $value; + } else { + $self->{$field}; + } +} + +package FS::UI::_Text; + +use vars qw ( @ISA ); + +@ISA = qw ( FS::UI::_Widget); + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + $self->{'_text'} = shift; + bless ( $self, $class ); +} + +sub sprint { + my $self = shift; + $self->{'_text'}; +} + +package FS::UI::_Link; + +use vars qw ( @ISA $BASE_URL ); + +@ISA = qw ( FS::UI::_Widget); +$BASE_URL = "http://rootwood.sisd.com/freeside"; + +sub sprint { + my $self = shift; + my $table = $self->{'table'}; + my $method = $self->{'method'}; + + # i will be cleaned up when we're done moving from the old webinterface! + my @arg = @{$self->{'arg'}}; + my $yuck = join( "&", @arg); + qq(<A HREF="$BASE_URL/$method/$table.cgi?$yuck">). $self->{'text'}. "<\A>"; +} + +package FS::UI::_Table; + +use vars qw ( @ISA ); + +@ISA = qw ( FS::UI::_Widget); + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class eq $proto ? { @_ } : $proto; + bless ( $self, $class ); + $self->{'_table'} = new HTML::Table ( $self->rows, $self->columns ); + $self; +} + +sub attach { + my $self = shift; + my ( $row, $column, $widget, $rowspan, $colspan ) = @_; + $self->{"_table"}->setCell( $row+1, $column+1, $widget->sprint ); + $self->{"_table"}->setCellRowSpan( $row+1, $column+1, $rowspan ) if $rowspan; + $self->{"_table"}->setCellColSpan( $row+1, $column+1, $colspan ) if $colspan; +} + +sub sprint { + my $self = shift; + $self->{'_table'}->getTable; +} + +package FS::UI::_Tableborder; + +use vars qw ( @ISA ); + +@ISA = qw ( FS::UI::_Table ); + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class eq $proto ? { @_ } : $proto; + bless ( $self, $class ); + $self->SUPER::new(@_); + $self->{'_table'}->setBorder; + $self; +} + +=head1 VERSION + +$Id: CGI.pm,v 1.1 1999-01-20 09:30:36 ivan Exp $ + +=head1 BUGS + +This documentation is incomplete. + +In _Tableborder, headers should be links that sort on their fields. + +_Link uses a constant $BASE_URL + +_Link passes the arguments as a manually-constructed GET string instead +of POSTing, for compatability while the web interface is upgraded. Once +this is done it should pass arguements properly (i.e. as a POST, 8-bit clean) + +Still some small bits of widget code same as FS::UI::Gtk. + +=head1 SEE ALSO + +L<FS::UI::Base> + +=head1 HISTORY + +$Log: CGI.pm,v $ +Revision 1.1 1999-01-20 09:30:36 ivan +skeletal cross-UI UI code. + + +=cut + +1; + diff --git a/site_perl/UI/Gtk.pm b/site_perl/UI/Gtk.pm new file mode 100644 index 000000000..498f05a47 --- /dev/null +++ b/site_perl/UI/Gtk.pm @@ -0,0 +1,221 @@ +package FS::UI::Gtk; + +use strict; +use Gtk; +use FS::UID qw(adminsuidsetup); + +die "Can't initialize Gtk interface; $FS::UI::Base::_lock used" + if $FS::UI::Base::_lock; +$FS::UI::Base::_lock = "FS::UI::Gtk"; + +=head1 NAME + +FS::UI::Gtk - Base class for Gtk user-interface objects + +=head1 SYNOPSIS + + use FS::UI::Gtk; + use FS::UI::some_table; + + $interface = new FS::UI::some_table; + + $error = $interface->browse; + $error = $interface->search; + $error = $interface->view; + $error = $interface->edit; + $error = $interface->process; + +=head1 DESCRIPTION + +An FS::UI::Gtk object represents a Gtk user interface object. + +=head1 METHODS + +=over 4 + +=item new + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = { @_ }; + + bless ( $self, $class ); + + $self->{'_user'} = 'ivan'; #Pop up login window? + $self->{'_dbh'} = FS::UID::adminsuidsetup $self->{'_user'}; + + + + $self; +} + +sub activate { + my $self = shift; + + my $vbox = new Gtk::VBox ( 0, 4 ); + + foreach my $widget ( @{ $self->{'Widgets'} } ) { + $widget->_gtk->show; + $vbox->pack_start ( $widget->_gtk, 1, 1, 4 ); + } + $vbox->show; + + my $window = new Gtk::Window "toplevel"; + $self->{'_gtk'} = $window; + $window->set_title( $self->title ); + $window->add ( $vbox ); + $window->show; + main Gtk; +} + +=item interface + +Returns the string `Gtk'. Useful for the author of a table-specific UI class +to conditionally specify certain behaviour. + +=cut + +sub interface { 'Gtk'; } + +=back + +=cut + +package FS::UI::_Widget; + +use vars qw( $AUTOLOAD ); + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = { @_ }; + bless ( $self, $class ); +} + +sub _gtk { + my $self = shift; + $self->{'_gtk'}; +} + +sub AUTOLOAD { + my $self = shift; + my $value = shift; + my($field)=$AUTOLOAD; + $field =~ s/.*://; + if ( defined($value) ) { + $self->{$field} = $value; + } else { + $self->{$field}; + } +} + +package FS::UI::_Text; + +use vars qw ( @ISA ); + +@ISA = qw ( FS::UI::_Widget ); + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + $self->{'_gtk'} = new Gtk::Label ( shift ); + bless ( $self, $class ); +} + +package FS::UI::_Link; + +use vars qw ( @ISA ); + +@ISA = qw ( FS::UI::_Widget ); + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = { @_ }; + $self->{'_gtk'} = new_with_label Gtk::Button ( $self->{'text'} ); + $self->{'_gtk'}->signal_connect( 'clicked', sub { + print "STUB: (Gtk) FS::UI::_Link"; + }, "hi", "there" ); + bless ( $self, $class ); +} + + +package FS::UI::_Table; + +use vars qw ( @ISA ); + +@ISA = qw ( FS::UI::_Widget ); + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = { @_ }; + bless ( $self, $class ); + + $self->{'_gtk'} = new Gtk::Table ( + $self->rows, + $self->columns, + 0, #homogeneous + ); + + $self; +} + +sub attach { + my $self = shift; + my ( $row, $column, $widget, $rowspan, $colspan ) = @_; + $rowspan ||= 1; + $colspan ||= 1; + $self->_gtk->attach_defaults( + $widget->_gtk, + $column, + $column + $colspan, + $row, + $row + $rowspan, + ); + $widget->_gtk->show; +} + +package FS::UI::_Tableborder; + +use vars qw ( @ISA ); + +@ISA = qw ( FS::UI::_Table ); + +=head1 VERSION + +$Id: Gtk.pm,v 1.1 1999-01-20 09:30:36 ivan Exp $ + +=head1 BUGS + +This documentation is incomplete. + +_Tableborder is just a _Table now. _Tableborders should scroll (but not the +headers) and need and need more decoration. (data in white section ala gtksql +and sliding field widths) headers should be buttons that callback to sort on +their fields. + +There should be a persistant, per-(freeside)-user store for window positions +and sizes and sort fields etc (see L<FS::UI::CGI/BUGS>. + +Still some small bits of widget code same as FS::UI::CGI. + +=head1 SEE ALSO + +L<FS::UI::Base> + +=head1 HISTORY + +$Log: Gtk.pm,v $ +Revision 1.1 1999-01-20 09:30:36 ivan +skeletal cross-UI UI code. + + +=cut + +1; + diff --git a/site_perl/UI/agent.pm b/site_perl/UI/agent.pm new file mode 100644 index 000000000..ce9744a55 --- /dev/null +++ b/site_perl/UI/agent.pm @@ -0,0 +1,62 @@ +package FS::UI::agent; + +use strict; +use vars qw ( @ISA ); +use FS::UI::Base; +use FS::Record qw( qsearchs ); +use FS::agent; +use FS::agent_type; + +@ISA = qw ( FS::UI::Base ); + +sub db_table { 'agent' }; + +sub db_name { 'Agent' }; + +sub db_description { <<END; +Agents are resellers of your service. Agents may be limited to a subset of your +full offerings (via their type). +END +} + +sub list_fields { + 'agentnum', + 'typenum', +# 'freq', +# 'prog', +; } + +sub list_header { + 'Agent', + 'Type', +# 'Freq (n/a)', +# 'Prog (n/a)', +; } + +sub db_callback { + 'agentnum' => + sub { + my ( $agentnum, $record ) = @_; + my $agent = $record->agent; + new FS::UI::_Link ( + 'table' => 'agent', + 'method' => 'edit', + 'arg' => [ $agentnum ], + 'text' => "$agentnum: $agent", + ); + }, + 'typenum' => + sub { + my $typenum = shift; + my $agent_type = qsearchs( 'agent_type', { 'typenum' => $typenum } ); + my $atype = $agent_type->atype; + new FS::UI::_Link ( + 'table' => 'agent_type', + 'method' => 'edit', + 'arg' => [ $typenum ], + 'text' => "$typenum: $atype" + ); + }, +} + +1; diff --git a/site_perl/UID.pm b/site_perl/UID.pm index 16f03a0ec..889ccb65f 100644 --- a/site_perl/UID.pm +++ b/site_perl/UID.pm @@ -2,7 +2,11 @@ package FS::UID; use strict; use vars qw( - @ISA @EXPORT_OK $cgi $dbh $freeside_uid $conf $datasrc $db_user $db_pass + @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; @@ -11,13 +15,11 @@ use FS::Conf; @ISA = qw(Exporter); @EXPORT_OK = qw(checkeuid checkruid swapuid cgisuidsetup - adminsuidsetup getotaker dbh datasrc); + adminsuidsetup getotaker dbh datasrc getsecrets ); $freeside_uid = scalar(getpwnam('freeside')); -my $conf = new FS::Conf; -($datasrc, $db_user, $db_pass) = $conf->config('secrets') - or die "Can't get secrets: $!"; +$conf_dir = "/usr/local/etc/freeside/"; =head1 NAME @@ -28,10 +30,9 @@ FS::UID - Subroutines for database login and assorted other stuff use FS::UID qw(adminsuidsetup cgisuidsetup dbh datasrc getotaker checkeuid checkruid swapuid); - adminsuidsetup; + adminsuidsetup $user; - $cgi = new CGI::Base; - $cgi->get; + $cgi = new CGI; $dbh = cgisuidsetup($cgi); $dbh = dbh; @@ -46,18 +47,23 @@ Provides a hodgepodge of subroutines. =over 4 -=item adminsuidsetup +=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"; @@ -66,28 +72,47 @@ sub adminsuidsetup { $ENV{'BASH_ENV'} = ''; croak "Not running uid freeside!" unless checkeuid(); + getsecrets; $dbh = DBI->connect($datasrc,$db_user,$db_pass, { - # hack for web demo - # my($user)=getotaker(); - # $dbh = DBI->connect("$datasrc:$user",$db_user,$db_pass, { 'AutoCommit' => 'true', 'ChopBlanks' => 'true', - } ) or die "DBI->connect error: $DBI::errstr\n";; + } ) 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::Base_OBJECT -Stores the CGI::Base_OBJECT for later use. +=item cgisuidsetup CGI_object + +Stores the CGI (see L<CGI>) object for later use. (CGI::Base is depriciated) Runs adminsuidsetup. =cut sub cgisuidsetup { - $cgi=$_[0]; - adminsuidsetup; + $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<CGI>) object. + +=cut + +sub cgi { + $cgi; } =item dbh @@ -121,17 +146,31 @@ sub suidsetup { =item getotaker -Returns the current Freeside user. Currently that means the CGI REMOTE_USER, -or 'freeside'. +Returns the current Freeside user. =cut sub getotaker { - if ($cgi && defined $cgi->var('REMOTE_USER')) { - return $cgi->var('REMOTE_USER'); #for now + $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 { - 'freeside'; + die "fatal: Can't get REMOTE_USER!"; } + $user; } =item checkeuid @@ -161,21 +200,65 @@ 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<FS::Record>, L<CGI::Base>, L<DBI> +L<FS::Record>, L<CGI>, L<DBI>, config.html from the base documentation. =head1 HISTORY @@ -203,6 +286,40 @@ 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 index 7fc370ed0..cc4fb1088 100644 --- a/site_perl/agent.pm +++ b/site_perl/agent.pm @@ -1,12 +1,12 @@ package FS::agent; use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(fields qsearch qsearchs); +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); +use FS::cust_main; +use FS::agent_type; -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); +@ISA = qw( FS::Record ); =head1 NAME @@ -16,8 +16,8 @@ FS::agent - Object methods for agent records use FS::agent; - $record = create FS::agent \%hash; - $record = create FS::agent { 'column' => 'value' }; + $record = new FS::agent \%hash; + $record = new FS::agent { 'column' => 'value' }; $error = $record->insert; @@ -51,38 +51,19 @@ from FS::Record. The following fields are currently supported: =over 4 -=item create HASHREF +=item new HASHREF Creates a new agent. To add the agent to the database, see L<"insert">. =cut -sub create { - my($proto,$hashref)=@_; - - #now in FS::Record::new - #my($field); - #foreach $field (fields('agent')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('agent',$hashref); -} +sub table { 'agent'; } =item insert Adds this agent to the database. If there is an error, returns the error, otherwise returns false. -=cut - -sub insert { - my($self)=@_; - - $self->check or - $self->add; -} - =item delete Deletes this agent from the database. Only agents with no customers can be @@ -91,10 +72,12 @@ deleted. If there is an error, returns the error, otherwise returns false. =cut sub delete { - my($self)=@_; + my $self = shift; + return "Can't delete an agent with customers!" - if qsearch('cust_main',{'agentnum' => $self->agentnum}); - $self->del; + if qsearch( 'cust_main', { 'agentnum' => $self->agentnum } ); + + $self->SUPER::delete; } =item replace OLD_RECORD @@ -102,17 +85,6 @@ sub delete { 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)=@_; - return "(Old) Not an agent record!" unless $old->table eq "agent"; - return "Can't change agentnum!" - unless $old->getfield('agentnum') eq $new->getfield('agentnum'); - $new->check or - $new->rep($old); -} - =item check Checks all fields to make sure this is a valid agent. If there is an error, @@ -122,20 +94,19 @@ methods. =cut sub check { - my($self)=@_; - return "Not a agent record!" unless $self->table eq "agent"; + my $self = shift; - my($error)= + my $error = $self->ut_numbern('agentnum') - or $self->ut_text('agent') - or $self->ut_number('typenum') - or $self->ut_numbern('freq') - or $self->ut_textn('prog') + || $self->ut_text('agent') + || $self->ut_number('typenum') + || $self->ut_numbern('freq') + || $self->ut_textn('prog') ; return $error if $error; return "Unknown typenum!" - unless qsearchs('agent_type',{'typenum'=> $self->getfield('typenum') }); + unless qsearchs( 'agent_type', { 'typenum' => $self->typenum } ); ''; @@ -143,9 +114,11 @@ sub check { =back -=head1 BUGS +=head1 VERSION -It doesn't properly override FS::Record yet. +$Id: agent.pm,v 1.4 1998-12-30 00:30:44 ivan Exp $ + +=head1 BUGS =head1 SEE ALSO diff --git a/site_perl/agent_type.pm b/site_perl/agent_type.pm index 002c36f54..54a91c8bf 100644 --- a/site_perl/agent_type.pm +++ b/site_perl/agent_type.pm @@ -1,12 +1,10 @@ package FS::agent_type; use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(qsearch fields); +use vars qw( @ISA ); +use FS::Record qw( qsearch ); -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); +@ISA = qw( FS::Record ); =head1 NAME @@ -16,8 +14,8 @@ FS::agent_type - Object methods for agent_type records use FS::agent_type; - $record = create FS::agent_type \%hash; - $record = create FS::agent_type { 'column' => 'value' }; + $record = new FS::agent_type \%hash; + $record = new FS::agent_type { 'column' => 'value' }; $error = $record->insert; @@ -47,40 +45,20 @@ FS::Record. The following fields are currently supported: =over 4 -=item create HASHREF +=item new HASHREF Creates a new agent type. To add the agent type to the database, see L<"insert">. =cut -sub create { - my($proto,$hashref)=@_; - - #now in FS::Record::new - #my($field); - #foreach $field (fields('agent_type')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('agent_type',$hashref); - -} +sub table { 'agent_type'; } =item insert Adds this agent type to the database. If there is an error, returns the error, otherwise returns false. -=cut - -sub insert { - my($self)=@_; - - $self->check or - $self->add; -} - =item delete Deletes this agent type from the database. Only agent types with no agents @@ -90,10 +68,12 @@ false. =cut sub delete { - my($self)=@_; + my $self = shift; + return "Can't delete an agent_type with agents!" - if qsearch('agent',{'typenum' => $self->typenum}); - $self->del; + if qsearch( 'agent', { 'typenum' => $self->typenum } ); + + $self->SUPER::delete; } =item replace OLD_RECORD @@ -101,17 +81,6 @@ sub delete { 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)=@_; - return "(Old) Not a agent_type record!" unless $old->table eq "agent_type"; - return "Can't change typenum!" - unless $old->getfield('typenum') eq $new->getfield('typenum'); - $new->check or - $new->rep($old); -} - =item check Checks all fields to make sure this is a valid agent type. If there is an @@ -121,8 +90,7 @@ replace methods. =cut sub check { - my($self)=@_; - return "Not a agent_type record!" unless $self->table eq "agent_type"; + my $self = shift; $self->ut_numbern('typenum') or $self->ut_text('atype'); @@ -131,9 +99,11 @@ sub check { =back -=head1 BUGS +=head1 VERSION + +$Id: agent_type.pm,v 1.2 1998-12-29 11:59:35 ivan Exp $ -It doesn't properly override FS::Record yet. +=head1 BUGS =head1 SEE ALSO @@ -155,6 +125,11 @@ Changed 'type' to 'atype' because Pg6.3 reserves the type word pod, added check in delete ivan@sisd.com 98-sep-21 +$Log: agent_type.pm,v $ +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 index 00234519a..0e87755ac 100644 --- a/site_perl/cust_bill.pm +++ b/site_perl/cust_bill.pm @@ -1,16 +1,22 @@ package FS::cust_bill; use strict; -use vars qw(@ISA $conf $add1 $add2 $add3 $add4); -use Exporter; +use vars qw( @ISA $conf $add1 $add2 $add3 $add4 ); use Date::Format; -use FS::Record qw(fields qsearch qsearchs); +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 Exporter); +@ISA = qw( FS::Record ); -$conf = new FS::Conf; - -($add1,$add2,$add3,$add4) = $conf->config('address'); +#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 @@ -20,8 +26,8 @@ FS::cust_bill - Object methods for cust_bill records use FS::cust_bill; - $record = create FS::cust_bill \%hash; - $record = create FS::cust_bill { 'column' => 'value' }; + $record = new FS::cust_bill \%hash; + $record = new FS::cust_bill { 'column' => 'value' }; $error = $record->insert; @@ -70,7 +76,7 @@ all payments (see L<FS::cust_pay>). =over 4 -=item create HASHREF +=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 @@ -78,17 +84,7 @@ Invoices are normally created by calling the bill method of a customer object =cut -sub create { - my($proto,$hashref)=@_; - - #now in FS::Record::new - #my($field); - #foreach $field (fields('cust_bill')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('cust_bill',$hashref); -} +sub table { 'cust_bill'; } =item insert @@ -101,14 +97,13 @@ automatically set to charged). =cut sub insert { - my($self)=@_; + my $self = shift; - $self->setfield('owed',$self->charged) if $self->owed eq ''; + $self->owed( $self->charged ) if $self->owed eq ''; return "owed != charged!" unless $self->owed == $self->charged; - $self->check or - $self->add; + $self->SUPER::insert; } =item delete @@ -120,8 +115,6 @@ no record you ever posted this invoice (which is bad, no?) sub delete { return "Can't remove invoice!" - #my($self)=@_; - #$self->del; } =item replace OLD_RECORD @@ -136,21 +129,14 @@ calling the collect method of a customer object (see L<FS::cust_main>). =cut sub replace { - my($new,$old)=@_; - return "(Old) Not a cust_bill record!" unless $old->table eq "cust_bill"; - return "Can't change invnum!" - unless $old->getfield('invnum') eq $new->getfield('invnum'); - return "Can't change custnum!" - unless $old->getfield('custnum') eq $new->getfield('custnum'); - return "Can't change _date!" - unless $old->getfield('_date') eq $new->getfield('_date'); - return "Can't change charged!" - unless $old->getfield('charged') eq $new->getfield('charged'); - return "(New) owed can't be > (new) charged!" - if $new->getfield('owed') > $new->getfield('charged'); - - $new->check or - $new->rep($old); + 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 @@ -162,30 +148,24 @@ methods. =cut sub check { - my($self)=@_; - return "Not a cust_bill record!" unless $self->table eq "cust_bill"; - my($recref) = $self->hashref; - - $recref->{invnum} =~ /^(\d*)$/ or return "Illegal invnum"; - $recref->{invnum} = $1; + 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; - $recref->{custnum} =~ /^(\d+)$/ or return "Illegal custnum"; - $recref->{custnum} = $1; return "Unknown customer" - unless qsearchs('cust_main',{'custnum'=>$recref->{custnum}}); - - $recref->{_date} =~ /^(\d*)$/ or return "Illegal date"; - $recref->{_date} = $recref->{_date} ? $1 : time; - - #$recref->{charged} =~ /^(\d+(\.\d\d)?)$/ or return "Illegal charged"; - $recref->{charged} =~ /^(\-?\d+(\.\d\d)?)$/ or return "Illegal charged"; - $recref->{charged} = $1; + unless qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); - $recref->{owed} =~ /^(\-?\d+(\.\d\d)?)$/ or return "Illegal owed"; - $recref->{owed} = $1; + $self->_date(time) unless $self->_date; - $recref->{printed} =~ /^(\d*)$/ or return "Illegal printed"; - $recref->{printed} = $1 || '0'; + $self->printed(0) if $self->printed eq ''; ''; #no error } @@ -198,13 +178,13 @@ followed by the previous outstanding invoices (as FS::cust_bill objects also). =cut sub previous { - my($self)=@_; - my($total)=0; - my(@cust_bill) = sort { $a->_date <=> $b->_date } + 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 } ) + qsearch( 'cust_bill', { 'custnum' => $self->custnum } ) ; - foreach (@cust_bill) { $total += $_->owed; } + foreach ( @cust_bill ) { $total += $_->owed; } $total, @cust_bill; } @@ -215,7 +195,7 @@ Returns the line items (see L<FS::cust_bill_pkg>) for this invoice. =cut sub cust_bill_pkg { - my($self)=@_; + my $self = shift; qsearch( 'cust_bill_pkg', { 'invnum' => $self->invnum } ); } @@ -228,9 +208,9 @@ credits (FS::cust_credit objects). =cut sub cust_credit { - my($self)=@_; - my($total)=0; - my(@cust_credit) = sort { $a->_date <=> $b->date } + 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 } ) ; @@ -245,7 +225,7 @@ Returns all payments (see L<FS::cust_pay>) for this invoice. =cut sub cust_pay { - my($self)=@_; + my $self = shift; sort { $a->_date <=> $b->date } qsearch( 'cust_pay', { 'invnum' => $self->invnum } ) ; @@ -264,216 +244,201 @@ L<Time::Local> and L<Date::Parse> for conversion functions. sub print_text { - my($self,$today)=@_; + my( $self, $today ) = ( shift, shift ); $today ||= time; - my($invnum)=$self->invnum; - my($cust_main) = qsearchs('cust_main', - { 'custnum', $self->custnum } ); - $cust_main->setfield('payname', - $cust_main->first. ' '. $cust_main->getfield('last') - ) unless $cust_main->payname; + 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; + 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) = ( + my $overdue = ( $balance_due > 0 && $today > $self->_date && $self->printed > 1 ); - #printing bits here - - local($SIG{CHLD}) = sub { wait() }; - $|=1; - my($pid)=open(CHILD,"-|"); - die "Can't fork: $!" unless defined($pid); - - if ($pid) { #parent - my(@collect)=<CHILD>; - close CHILD; - return @collect; - } else { #child - - my($description,$amount); - my(@buf); - - #define format stuff - $%=0; - $= = 35; - local($^L) = <<END; - - - - + #printing bits here (yuck!) + my @collect = (); + my($description,$amount); + my(@buf); -END + #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,('',''); + } - #format address - my($l,@address)=(0,'','','','',''); - $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 ) { - #new charges - foreach ( $self->cust_bill_pkg ) { + if ( $_->pkgnum ) { - 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; - 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; + } - push @buf, ( "$pkg Setup",'$' . sprintf("%10.2f",$_->setup) ) - if $_->setup != 0; + if ( $_->recur != 0 ) { push @buf, ( "$pkg (" . time2str("%x",$_->sdate) . " - " . time2str("%x",$_->edate) . ")", '$' . sprintf("%10.2f",$_->recur) - ) if $_->recur != 0; - - } else { #pkgnum Tax - push @buf,("Tax",'$' . sprintf("%10.2f",$_->setup) ) - if $_->setup != 0; + ); + push @buf, map { " ". $_->[0]. ": ". $_->[1], '' } $cust_pkg->labels; } - } - - 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) - ); + } else { #pkgnum Tax + push @buf,("Tax",'$' . sprintf("%10.2f",$_->setup) ) + if $_->setup != 0; } - - #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_pages)=int(scalar(@buf)/30); #15 lines, 2 values per line - $tot_pages++ if scalar(@buf) % 30; - - while (@buf) { + } + + 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); - write; + push @collect, myswrite($description, $amount); } - ($description,$amount)=('',''); - write while ( $- ); - print $^L; - - exit; #kid - - format STDOUT_TOP = - - @||||||||||||||||||| - "Invoice" - @||||||||||||||||||| @<<<<<<< @<<<<<<<<<<< -{ - ( $tot_pages != 1 ) ? "Page $% of $tot_pages" : '', - time2str("%x",( $self->_date )), "FS-$invnum" -} - - -@>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -$add1 -@>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -$add2 -@>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -$add3 -@>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -$add4 - - @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -{ $cust_main->payname, - ( ( $cust_main->payby eq 'BILL' ) && $cust_main->payinfo ) - ? "P.O. #". $cust_main->payinfo : '' -} - @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -$address[0],'' - @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -$address[1],$overdue ? "* This invoice is now PAST DUE! *" : '' - @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -$address[2],$overdue ? " Please forward payment promptly " : '' - @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -$address[3],$overdue ? "to avoid interruption of service." : '' - @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -$address[4],'' - - - -. - - format STDOUT = + $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 = <<END; @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<< - $description,$amount -. - - } #endchild +END + $^A = ''; + formline( $format, @_ ); + return $^A; + } } =back +=head1 VERSION + +$Id: cust_bill.pm,v 1.7 1999-02-09 09:55:05 ivan Exp $ + =head1 BUGS The delete method. -It doesn't properly override FS::Record yet. - -print_text formatting (and some logic :/) is in source as a format declaration, -which needs to be slurped in from a file. the fork is rather kludgy as well. -It could be cleaned with swrite from man perlform, and the picture could be -put in a /var/spool/freeside/conf file. Also number of lines ($=). +print_text formatting (and some logic :/) is in source, but needs to be +slurped in from a file. Also number of lines ($=). missing print_ps for a nice postscript copy (maybe HylaFAX-cover-page-style or something similar so the look can be completely customized?) -There is an off-by-one error in print_text which causes a visual error: "Page 1 -of 2" printed on some single-page invoices? - =head1 SEE ALSO L<FS::Record>, L<FS::cust_main>, L<FS::cust_pay>, L<FS::cust_bill_pkg>, @@ -489,6 +454,28 @@ 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 index e41d7c12c..a52539433 100644 --- a/site_perl/cust_bill_pkg.pm +++ b/site_perl/cust_bill_pkg.pm @@ -1,12 +1,12 @@ package FS::cust_bill_pkg; use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(fields qsearchs); +use vars qw( @ISA ); +use FS::Record qw( qsearchs ); +use FS::cust_pkg; +use FS::cust_bill; -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); +@ISA = qw(FS::Record ); =head1 NAME @@ -16,8 +16,8 @@ FS::cust_bill_pkg - Object methods for cust_bill_pkg records use FS::cust_bill_pkg; - $record = create FS::cust_bill_pkg \%hash; - $record = create FS::cust_bill_pkg { 'column' => 'value' }; + $record = new FS::cust_bill_pkg \%hash; + $record = new FS::cust_bill_pkg { 'column' => 'value' }; $error = $record->insert; @@ -56,7 +56,7 @@ see L<Time::Local> and L<Date::Parse> for conversion functions. =over 4 -=item create HASHREF +=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 @@ -64,33 +64,13 @@ customer object (see L<FS::cust_main>). =cut -sub create { - my($proto,$hashref)=@_; - - #now in FS::Record::new - #my($field); - #foreach $field (fields('cust_bill_pkg')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('cust_bill_pkg',$hashref); - -} +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. -=cut - -sub insert { - my($self)=@_; - - $self->check or - $self->add; -} - =item delete Currently unimplemented. I don't remove line items because there would then be @@ -100,8 +80,6 @@ no record the items ever existed (which is bad, no?) sub delete { return "Can't delete cust_bill_pkg records!"; - #my($self)=@_; - #$self->del; } =item replace OLD_RECORD @@ -113,12 +91,6 @@ than deleteing the items. Just don't do it. sub replace { return "Can't modify cust_bill_pkg records!"; - #my($new,$old)=@_; - #return "(Old) Not a cust_bill_pkg record!" - # unless $old->table eq "cust_bill_pkg"; - # - #$new->check or - #$new->rep($old); } =item check @@ -130,35 +102,36 @@ method. =cut sub check { - my($self)=@_; - return "Not a cust_bill_pkg record!" unless $self->table eq "cust_bill_pkg"; + my $self = shift; - my($error)= + my $error = $self->ut_number('pkgnum') - or $self->ut_number('invnum') - or $self->ut_money('setup') - or $self->ut_money('recur') - or $self->ut_numbern('sdate') - or $self->ut_numbern('edate') + || $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 pkgnum ". $self->pkgnum + unless qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } ); } return "Unknown invnum" - unless qsearchs('cust_bill',{'invnum'=> $self->invnum }); + unless qsearchs( 'cust_bill' ,{ 'invnum' => $self->invnum } ); ''; #no error } =back -=head1 BUGS +=head1 VERSION + +$Id: cust_bill_pkg.pm,v 1.2 1998-12-29 11:59:37 ivan Exp $ -It doesn't properly override FS::Record yet. +=head1 BUGS =head1 SEE ALSO diff --git a/site_perl/cust_credit.pm b/site_perl/cust_credit.pm index b1a5e1649..b9a05832b 100644 --- a/site_perl/cust_credit.pm +++ b/site_perl/cust_credit.pm @@ -1,13 +1,12 @@ package FS::cust_credit; use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::UID qw(getotaker); -use FS::Record qw(fields qsearchs); +use vars qw( @ISA ); +use FS::UID qw( getotaker ); +use FS::Record qw( qsearchs ); +use FS::cust_main; -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); +@ISA = qw( FS::Record ); =head1 NAME @@ -17,8 +16,8 @@ FS::cust_credit - Object methods for cust_credit records use FS::cust_credit; - $record = create FS::cust_credit \%hash; - $record = create FS::cust_credit { 'column' => 'value' }; + $record = new FS::cust_credit \%hash; + $record = new FS::cust_credit { 'column' => 'value' }; $error = $record->insert; @@ -57,23 +56,13 @@ L<Time::Local> and L<Date::Parse> for conversion functions. =over 4 -=item create HASHREF +=item new HASHREF Creates a new credit. To add the credit to the database, see L<"insert">. =cut -sub create { - my($proto,$hashref)=@_; - - #now in FS::Record::new - #my($field); - #foreach $field (fields('cust_credit')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('cust_credit',$hashref); -} +sub table { 'cust_credit'; } =item insert @@ -86,14 +75,18 @@ automatically set to amount). =cut sub insert { - my($self)=@_; + my $self = shift; + + my $error; + return $error if $error = $self->ut_money('credited') + || $self->ut_money('amount'); - $self->setfield('credited',$self->amount) if $self->credited eq ''; + $self->credited($self->amount) if $self->credited == 0 + || $self->credited eq ''; return "credited != amount!" unless $self->credited == $self->amount; - $self->check or - $self->add; + $self->SUPER::insert; } =item delete @@ -104,8 +97,6 @@ Currently unimplemented. sub delete { return "Can't remove credit!" - #my($self)=@_; - #$self->del; } =item replace OLD_RECORD @@ -119,21 +110,16 @@ inserting a refund (see L<FS::cust_refund>). =cut sub replace { - my($new,$old)=@_; - return "(Old) Not a cust_credit record!" unless $old->table eq "cust_credit"; - return "Can't change crednum!" - unless $old->getfield('crednum') eq $new->getfield('crednum'); - return "Can't change custnum!" - unless $old->getfield('custnum') eq $new->getfield('custnum'); - return "Can't change date!" - unless $old->getfield('_date') eq $new->getfield('_date'); - return "Can't change amount!" - unless $old->getfield('amount') eq $new->getfield('amount'); + 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->getfield('credited') > $new->getfield('amount'); + if $new->credited > $new->amount; - $new->check or - $new->rep($old); + $new->SUPER::replace($old); } =item check @@ -145,43 +131,38 @@ methods. =cut sub check { - my($self)=@_; - return "Not a cust_credit record!" unless $self->table eq "cust_credit"; - my($recref) = $self->hashref; - - $recref->{crednum} =~ /^(\d*)$/ or return "Illegal crednum"; - $recref->{crednum} = $1; + 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; - $recref->{custnum} =~ /^(\d+)$/ or return "Illegal custnum"; - $recref->{custnum} = $1; return "Unknown customer" - unless qsearchs('cust_main',{'custnum'=>$recref->{custnum}}); - - $recref->{_date} =~ /^(\d*)$/ or return "Illegal date"; - $recref->{_date} = $recref->{_date} ? $1 : time; - - $recref->{amount} =~ /^(\d+(\.\d\d)?)$/ or return "Illegal amount"; - $recref->{amount} = $1; + unless qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); - $recref->{credited} =~ /^(\-?\d+(\.\d\d)?)$/ or return "Illegal credited"; - $recref->{credited} = $1; + $self->_date(time) unless $self->_date; - #$recref->{otaker} =~ /^(\w+)$/ or return "Illegal otaker"; - #$recref->{otaker} = $1; $self->otaker(getotaker); - $self->ut_textn('reason'); - + ''; #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. -It doesn't properly override FS::Record yet. - =head1 SEE ALSO L<FS::Record>, L<FS::cust_refund>, L<FS::cust_bill>, schema.html from the base @@ -193,6 +174,17 @@ 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 index ec282731e..7bdbc08ac 100644 --- a/site_perl/cust_main.pm +++ b/site_perl/cust_main.pm @@ -5,58 +5,70 @@ use vars qw($paymentserversecret $paymentserverport $paymentserverhost); package FS::cust_main; use strict; -use vars qw(@ISA @EXPORT_OK $conf $lpr $processor $xaction $E_NoErr); +use vars qw( @ISA $conf $lpr $processor $xaction $E_NoErr $invoice_from + $smtpmachine ); use Safe; -use Exporter; 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(fields hfields qsearchs qsearch); +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_pay_batch; - -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(hfields); - -$conf = new FS::Conf; -$lpr = $conf->config('lpr'); - -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" +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"; } - 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'; } - $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 @@ -66,8 +78,8 @@ FS::cust_main - Object methods for cust_main records use FS::cust_main; - $record = create FS::cust_main \%hash; - $record = create FS::cust_main { 'column' => 'value' }; + $record = new FS::cust_main \%hash; + $record = new FS::cust_main { 'column' => 'value' }; $error = $record->insert; @@ -149,7 +161,7 @@ FS::Record. The following fields are currently supported: =over 4 -=item create HASHREF +=item new HASHREF Creates a new customer. To add the customer to the database, see L<"insert">. @@ -158,39 +170,13 @@ points to. You can ask the object for a copy with the I<hash> method. =cut -sub create { - my($proto,$hashref)=@_; - - #now in FS::Record::new - #my $field; - #foreach $field (fields('cust_main')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('cust_main',$hashref); -} +sub table { 'cust_main'; } =item insert Adds this customer to the database. If there is an error, returns the error, otherwise returns false. -=cut - -sub insert { - my($self)=@_; - - #no callbacks in check, only data checks - #local $SIG{HUP} = 'IGNORE'; - #local $SIG{INT} = 'IGNORE'; - #local $SIG{QUIT} = 'IGNORE'; - #local $SIG{TERM} = 'IGNORE'; - #local $SIG{TSTP} = 'IGNORE'; - - $self->check or - $self->add; -} - =item delete Currently unimplemented. Maybe cancel all of this customer's @@ -201,12 +187,8 @@ be no record the customer ever existed (which is bad, no?) =cut -# Usage: $error = $record -> delete; sub delete { return "Can't (yet?) delete customers."; -# my($self)=@_; -# -# $self->del; } =item replace OLD_RECORD @@ -214,17 +196,6 @@ sub delete { 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)=@_; - return "(Old) Not a cust_main record!" unless $old->table eq "cust_main"; - return "Can't change custnum!" - unless $old->getfield('custnum') eq $new->getfield('custnum'); - $new->check or - $new->rep($old); -} - =item check Checks all fields to make sure this is a valid customer record. If there is @@ -234,19 +205,18 @@ and repalce methods. =cut sub check { - my($self)=@_; - - return "Not a cust_main record!" unless $self->table eq "cust_main"; + my $self = shift; my $error = - $self->ut_number('agentnum') + $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_text('state') + || $self->ut_textn('state') || $self->ut_phonen('daytime') || $self->ut_phonen('night') || $self->ut_phonen('fax') @@ -254,15 +224,17 @@ sub check { return $error if $error; return "Unknown agent" - unless qsearchs('agent',{'agentnum'=>$self->agentnum}); + unless qsearchs( 'agent', { 'agentnum' => $self->agentnum } ); return "Unknown referral" - unless qsearchs('part_referral',{'refnum'=>$self->refnum}); + unless qsearchs( 'part_referral', { 'refnum' => $self->refnum } ); - $self->getfield('last') =~ /^([\w \,\.\-\']+)$/ or return "Illegal last name"; + $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 =~ /^([\w \,\.\-\']+)$/ + or return "Illegal first name: ". $self->first; $self->first($1); if ( $self->ss eq '' ) { @@ -271,25 +243,31 @@ sub check { my $ss = $self->ss; $ss =~ s/\D//g; $ss =~ /^(\d{3})(\d{2})(\d{4})$/ - or return "Illegal social security number"; + or return "Illegal social security number: ". $self->ss; $self->ss("$1-$2-$3"); } - return "Unknown state/county/country" - unless qsearchs('cust_main_county',{ - 'state' => $self->state, - 'county' => $self->county, - } ); + $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, + } ); + } - #int'l zips? - $self->zip =~ /^(\d{5}(-\d{4})?)$/ or return "Illegal zip"; + $self->zip =~ /^\s*(\w[\w\-\s]{3,8}\w)\s*$/ + or return "Illegal zip: ". $self->zip; $self->zip($1); - #int'l countries! - $self->country =~ /^(US)$/ or return "Illegal country"; - $self->country($1); - - $self->payby =~ /^(CARD|BILL|COMP)$/ or return "Illegal payby"; + $self->payby =~ /^(CARD|BILL|COMP)$/ + or return "Illegal payby: ". $self->payby; $self->payby($1); if ( $self->payby eq 'CARD' ) { @@ -297,26 +275,22 @@ sub check { my $payinfo = $self->payinfo; $payinfo =~ s/\D//g; $payinfo =~ /^(\d{13,16})$/ - or return "Illegal credit card number"; + or return "Illegal credit card number: ". $self->payinfo; $payinfo = $1; $self->payinfo($payinfo); - validate($payinfo) or return "Illegal credit card number"; - my $type = cardtype($payinfo); - return "Unknown credit card type" - unless ( $type =~ /^VISA/ || - $type =~ /^MasterCard/ || - $type =~ /^American Express/ || - $type =~ /^Discover/ ); + 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' ) { - $self->payinfo =~ /^([\w \-]*)$/ or return "Illegal P.O. number"; - $self->payinfo($1); + $error = $self->ut_textn('payinfo'); + return "Illegal P.O. number: ". $self->payinfo if $error; } elsif ( $self->payby eq 'COMP' ) { - $self->payinfo =~ /^(\w{2,8})$/ or return "Illegal comp account issuer"; - $self->payinfo($1); + $error = $self->ut_textn('payinfo'); + return "Illegal comp account issuer: ". $self->payinfo if $error; } @@ -325,7 +299,7 @@ sub check { $self->paydate(''); } else { $self->paydate =~ /^(\d{1,2})[\/\-](\d{2}(\d{2})?)$/ - or return "Illegal expiration date"; + 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" @@ -339,11 +313,11 @@ sub check { $self->payname( $self->first. " ". $self->getfield('last') ); } else { $self->payname =~ /^([\w \,\.\-\']+)$/ - or return "Illegal billing name"; + or return "Illegal billing name: ". $self->payname; $self->payname($1); } - $self->tax =~ /^(Y?)$/ or return "Illegal tax"; + $self->tax =~ /^(Y?)$/ or return "Illegal tax: ". $self->tax; $self->tax($1); $self->otaker(getotaker); @@ -358,7 +332,7 @@ Returns all packages (see L<FS::cust_pkg>) for this customer. =cut sub all_pkgs { - my($self)=@_; + my $self = shift; qsearch( 'cust_pkg', { 'custnum' => $self->custnum }); } @@ -369,7 +343,7 @@ Returns all non-cancelled packages (see L<FS::cust_pkg>) for this customer. =cut sub ncancelled_pkgs { - my($self)=@_; + my $self = shift; qsearch( 'cust_pkg', { 'custnum' => $self->custnum, 'cancel' => '', @@ -391,10 +365,10 @@ If there is an error, returns the error, otherwise returns false. =cut sub bill { - my($self,%options)=@_; - my($time) = $options{'time'} || $^T; + my( $self, %options ) = @_; + my $time = $options{'time'} || time; - my($error); + my $error; #put below somehow? local $SIG{HUP} = 'IGNORE'; @@ -402,42 +376,38 @@ sub bill { 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( $total_setup, $total_recur ) = ( 0, 0 ); + my @cust_bill_pkg; - my(@cust_bill_pkg); - - my($cust_pkg); - foreach $cust_pkg ( + foreach my $cust_pkg ( qsearch('cust_pkg',{'custnum'=> $self->getfield('custnum') } ) ) { - bless($cust_pkg,"FS::cust_pkg"); - - next if ( $cust_pkg->getfield('cancel') ); + 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 } ); + 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)=create FS::cust_pkg(\%hash); + 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; + my $setup = 0; unless ( $cust_pkg->setup ) { - my($setup_prog)=$part_pkg->getfield('setup'); - my($cpt) = new Safe; + 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? + $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 ", @@ -449,16 +419,16 @@ sub bill { } #bill recurring fee - my($recur)=0; - my($sdate); + 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; + 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? + $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 ", @@ -467,13 +437,14 @@ sub bill { #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)= + $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; + $cust_pkg->setfield('bill', + timelocal($sec,$min,$hour,$mday,$mon,$year)); + $cust_pkg_mod_flag = 1; } } @@ -481,15 +452,14 @@ sub bill { warn "recur is undefinded" unless defined($recur); warn "cust_pkg bill is undefinded" unless defined($cust_pkg->bill); - if ($cust_pkg_mod_flag) { + if ( $cust_pkg_mod_flag ) { $error=$cust_pkg->replace($old_cust_pkg); - if ( $error ) { + if ( $error ) { #just in case warn "Error modifying pkgnum ", $cust_pkg->pkgnum, ": $error"; } else { - #just in case - $setup=sprintf("%.2f",$setup); - $recur=sprintf("%.2f",$recur); - my($cust_bill_pkg)=create FS::cust_bill_pkg ({ + $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, @@ -504,24 +474,24 @@ sub bill { } - my($charged)=sprintf("%.2f",$total_setup + $total_recur); + my $charged = sprintf( "%.2f", $total_setup + $total_recur ); return '' if scalar(@cust_bill_pkg) == 0; - unless ( $self->getfield('tax') eq 'Y' || - $self->getfield('tax') eq 'y' || - $self->getfield('payby') eq 'COMP' + unless ( $self->getfield('tax') =~ /Y/i + || $self->getfield('payby') eq 'COMP' ) { - my($cust_main_county) = qsearchs('cust_main_county',{ - 'county' => $self->getfield('county'), - 'state' => $self->getfield('state'), + my $cust_main_county = qsearchs('cust_main_county',{ + 'state' => $self->state, + 'county' => $self->county, + 'country' => $self->country, } ); - my($tax) = sprintf("%.2f", + my $tax = sprintf( "%.2f", $charged * ( $cust_main_county->getfield('tax') / 100 ) ); - $charged = sprintf("%.2f",$charged+$tax); + $charged = sprintf( "%.2f", $charged+$tax ); - my($cust_bill_pkg)=create FS::cust_bill_pkg ({ + my $cust_bill_pkg = new FS::cust_bill_pkg ({ 'pkgnum' => 0, 'setup' => $tax, 'recur' => 0, @@ -531,23 +501,23 @@ sub bill { push @cust_bill_pkg, $cust_bill_pkg; } - my($cust_bill) = create FS::cust_bill ( { + my $cust_bill = new FS::cust_bill ( { 'custnum' => $self->getfield('custnum'), '_date' => $time, 'charged' => $charged, } ); - $error=$cust_bill->insert; + $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); + 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; + $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" @@ -583,10 +553,10 @@ return an error. By default, they don't. =cut sub collect { - my($self,%options)=@_; - my($invoice_time) = $options{'invoice_time'} || $^T; + my( $self, %options ) = @_; + my $invoice_time = $options{'invoice_time'} || time; - my($total_owed) = $self->balance; + my $total_owed = $self->balance; return '' unless $total_owed > 0; #redundant????? #put below somehow? @@ -595,89 +565,109 @@ sub collect { 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->getfield('custnum'), - } ) ) { + 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 + my $amount = sprintf( "%.2f", $total_owed < $cust_bill->owed ? $total_owed : $cust_bill->owed ); - $total_owed = sprintf("%.2f",$total_owed-$amount); + $total_owed = sprintf( "%.2f", $total_owed - $amount ); next unless $cust_bill->owed > 0; - next if qsearchs('cust_pay_batch',{'invnum'=> $cust_bill->invnum }); + 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->getfield('payby') eq 'BILL' ) { + if ( $self->payby eq 'BILL' ) { #30 days 2592000 - my($since)=$invoice_time - ( $cust_bill->_date || 0 ); + 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 ) { - open(LPR,$lpr) or die "Can't open $lpr: $!"; - print LPR $cust_bill->print_text; #( date ) - close LPR - or die $! ? "Error closing $lpr: $!" - : "Exit status $? from $lpr"; + #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; + my %hash = $cust_bill->hash; $hash{'printed'}++; - my($new_cust_bill)=create FS::cust_bill(\%hash); - my($error)=$new_cust_bill->replace($cust_bill); - if ( $error ) { - warn "Error updating $cust_bill->printed: $error"; - } + 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->getfield('payby') eq 'COMP' ) { - my($cust_pay) = create FS::cust_pay ( { - 'invnum' => $cust_bill->getfield('invnum'), + } elsif ( $self->payby eq 'COMP' ) { + my $cust_pay = new FS::cust_pay ( { + 'invnum' => $cust_bill->invnum, 'paid' => $amount, '_date' => '', 'payby' => 'COMP', - 'payinfo' => $self->getfield('payinfo'), + 'payinfo' => $self->payinfo, 'paybatch' => '' } ); - my($error)=$cust_pay->insert; - return 'Error COMPing invnum #' . $cust_bill->getfield('invnum') . + my $error = $cust_pay->insert; + return 'Error COMPing invnum #' . $cust_bill->invnum . ':' . $error if $error; - } elsif ( $self->getfield('payby') eq 'CARD' ) { + + } elsif ( $self->payby eq 'CARD' ) { if ( $options{'batch_card'} ne 'yes' ) { return "Real time card processing not enabled!" unless $processor; - if ( $processor =~ /cybercash/ ) { + if ( $processor =~ /^cybercash/ ) { #fix exp. date for cybercash - $self->getfield('paydate') =~ /^(\d+)\/\d*(\d{2})$/; - my($exp)="$1/$2"; + #$self->paydate =~ /^(\d+)\/\d*(\d{2})$/; + $self->paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/; + my $exp = "$2/$1"; - my($paybatch)= $cust_bill->getfield('invnum') . - '-' . time2str("%y%m%d%H%M%S",time); + my $paybatch = $cust_bill->invnum. + '-' . time2str("%y%m%d%H%M%S", time); - my($payname)= $self->getfield('payname') || - $self->getfield('first') . ' ' .$self->getfield('last'); + my $payname = $self->payname || + $self->getfield('first'). ' '. $self->getfield('last'); - my($address)= $self->getfield('address1'); - $address .= ", " . $self->getfield('address2') - if $self->getfield('address2'); + my $address = $self->address1; + $address .= ", ". $self->address2 if $self->address2; - my($country) = $self->getfield('country') eq 'US' ? - 'USA' : $self->getfield('country'); + my $country = 'USA' if $self->country eq 'US'; - my(@full_xaction)=($xaction, + my @full_xaction = ( $xaction, 'Order-ID' => $paybatch, 'Amount' => "usd $amount", 'Card-Number' => $self->getfield('payinfo'), @@ -690,7 +680,7 @@ sub collect { 'Card-Exp' => $exp, ); - my(%result); + my %result; if ( $processor eq 'cybercash2' ) { $^W=0; #CCLib isn't -w safe, ugh! %result = &CCLib::sendmserver(@full_xaction); @@ -704,21 +694,21 @@ sub collect { #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) = create FS::cust_pay ( { - 'invnum' => $cust_bill->getfield('invnum'), + my $cust_pay = new FS::cust_pay ( { + 'invnum' => $cust_bill->invnum, 'paid' => $amount, '_date' => '', 'payby' => 'CARD', - 'payinfo' => $self->getfield('payinfo'), + 'payinfo' => $self->payinfo, 'paybatch' => "$processor:$paybatch", } ); - my($error)=$cust_pay->insert; + my $error = $cust_pay->insert; return 'Error applying payment, invnum #' . - $cust_bill->getfield('invnum') . ':' . $error if $error; + $cust_bill->invnum. ':'. $error if $error; } elsif ( $result{'Mstatus'} ne 'failure-bad-money' || $options{'report_badcard'} ) { return 'Cybercash error, invnum #' . - $cust_bill->getfield('invnum') . ':' . $result{'MErrMsg'}; + $cust_bill->invnum. ':'. $result{'MErrMsg'}; } else { return ''; } @@ -729,8 +719,7 @@ sub collect { } else { #batch card -# my($cust_pay_batch) = create FS::cust_pay_batch ( { - my($cust_pay_batch) = new FS::Record ('cust_pay_batch', { + my $cust_pay_batch = new FS::Record ('cust_pay_batch', { 'invnum' => $cust_bill->getfield('invnum'), 'custnum' => $self->getfield('custnum'), 'last' => $self->getfield('last'), @@ -747,16 +736,19 @@ sub collect { 'payname' => $self->getfield('payname'), 'amount' => $amount, } ); -# my($error)=$cust_pay_batch->insert; - my($error)=$cust_pay_batch->add; + my $error = $cust_pay_batch->insert; return "Error adding to cust_pay_batch: $error" if $error; } } else { - return "Unknown payment type ".$self->getfield('payby'); + return "Unknown payment type ". $self->payby; } + + + + } ''; @@ -770,15 +762,14 @@ Returns the total owed for this customer on all invoices =cut sub total_owed { - my($self) = @_; - my($total_bill) = 0; - my($cust_bill); - foreach $cust_bill ( qsearch('cust_bill', { - 'custnum' => $self->getfield('custnum'), + my $self = shift; + my $total_bill = 0; + foreach my $cust_bill ( qsearch('cust_bill', { + 'custnum' => $self->custnum, } ) ) { - $total_bill += $cust_bill->getfield('owed'); + $total_bill += $cust_bill->owed; } - sprintf("%.2f",$total_bill); + sprintf( "%.2f", $total_bill ); } =item total_credited @@ -788,15 +779,14 @@ Returns the total credits (see L<FS::cust_credit>) for this customer. =cut sub total_credited { - my($self) = @_; - my($total_credit) = 0; - my($cust_credit); - foreach $cust_credit ( qsearch('cust_credit', { - 'custnum' => $self->getfield('custnum'), + my $self = shift; + my $total_credit = 0; + foreach my $cust_credit ( qsearch('cust_credit', { + 'custnum' => $self->custnum, } ) ) { - $total_credit += $cust_credit->getfield('credited'); + $total_credit += $cust_credit->credited; } - sprintf("%.2f",$total_credit); + sprintf( "%.2f", $total_credit ); } =item balance @@ -806,30 +796,119 @@ Returns the balance for this customer (total owed minus total credited). =cut sub balance { - my($self) = @_; - sprintf("%.2f",$self->total_bill - $self->total_credit); + 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<FS::cust_main_invoice>). 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 BUGS +=head1 VERSION -The delete method. +$Id: cust_main.pm,v 1.21 1999-04-14 07:47:53 ivan Exp $ -It doesn't properly override FS::Record yet. +=head1 BUGS -hfields should be removed. +The delete method. 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<FS::Record>, L<FS::cust_pkg>, L<FS::cust_bill>, L<FS::cust_credit> L<FS::cust_pay_batch>, L<FS::agent>, L<FS::part_referral>, -L<FS::cust_main_county>, L<FS::UID>, schema.html from the base documentation. +L<FS::cust_main_county>, L<FS::cust_main_invoice>, +L<FS::UID>, schema.html from the base documentation. =head1 HISTORY @@ -861,6 +940,71 @@ 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.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 <clgray@bcgroup.net> + +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 index f4b4595ae..1ecaed1ec 100644 --- a/site_perl/cust_main_county.pm +++ b/site_perl/cust_main_county.pm @@ -1,12 +1,10 @@ package FS::cust_main_county; use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(fields hfields qsearch qsearchs); +use vars qw( @ISA ); +use FS::Record; -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(hfields); +@ISA = qw( FS::Record ); =head1 NAME @@ -16,8 +14,8 @@ FS::cust_main_county - Object methods for cust_main_county objects use FS::cust_main_county; - $record = create FS::cust_main_county \%hash; - $record = create FS::cust_main_county { 'column' => 'value' }; + $record = new FS::cust_main_county \%hash; + $record = new FS::cust_main_county { 'column' => 'value' }; $error = $record->insert; @@ -41,6 +39,8 @@ currently supported: =item county +=item country + =item tax - percentage =back @@ -49,68 +49,29 @@ currently supported: =over 4 -=item create HASHREF +=item new HASHREF Creates a new tax rate. To add the tax rate to the database, see L<"insert">. =cut -sub create { - my($proto,$hashref)=@_; - - #now in FS::Record::new - #my($field); - #foreach $field (fields('cust_main_county')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('cust_main_county',$hashref); -} +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. -=cut - -sub insert { - my($self)=@_; - - $self->check or - $self->add; -} - =item delete Deletes this tax rate from the database. If there is an error, returns the error, otherwise returns false. -=cut - -sub delete { - my($self)=@_; - - $self->del; -} - =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)=@_; - return "(Old) Not a cust_main_county record!" - unless $old->table eq "cust_main_county"; - return "Can't change taxnum!" - unless $old->getfield('taxnum') eq $new->getfield('taxnum'); - $new->check or - $new->rep($old); -} - =item check Checks all fields to make sure this is a valid tax rate. If there is an error, @@ -120,26 +81,23 @@ methods. =cut sub check { - my($self)=@_; - return "Not a cust_main_county record!" - unless $self->table eq "cust_main_county"; - my($recref) = $self->hashref; + my $self = shift; $self->ut_numbern('taxnum') - or $self->ut_text('state') - or $self->ut_textn('county') - or $self->ut_float('tax') + || $self->ut_textn('state') + || $self->ut_textn('county') + || $self->ut_float('tax') ; } =back -=head1 BUGS +=head1 VERSION -It doesn't properly override FS::Record yet. +$Id: cust_main_county.pm,v 1.3 1998-12-29 11:59:41 ivan Exp $ -A country field (and possibly a currency field) should be added. +=head1 BUGS =head1 SEE ALSO @@ -155,6 +113,14 @@ Changed check for 'tax' to use the new ut_float subroutine pod ivan@sisd.com 98-sep-21 +$Log: cust_main_county.pm,v $ +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 new file mode 100644 index 000000000..2823294c1 --- /dev/null +++ b/site_perl/cust_main_invoice.pm @@ -0,0 +1,214 @@ +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<FS::cust_main>) + +=item dest - Invoice destination: If numeric, a <a href="#svc_acct">svcnum</a>, 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<hash> 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<FS::Record>, L<FS::cust_main> + +=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 index 6e30c595b..2cb256baa 100644 --- a/site_perl/cust_pay.pm +++ b/site_perl/cust_pay.pm @@ -1,14 +1,12 @@ package FS::cust_pay; use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; +use vars qw( @ISA ); use Business::CreditCard; -use FS::Record qw(fields qsearchs); +use FS::Record qw( qsearchs ); use FS::cust_bill; -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); +@ISA = qw( FS::Record ); =head1 NAME @@ -18,8 +16,8 @@ FS::cust_pay - Object methods for cust_pay objects use FS::cust_pay; - $record = create FS::cust_pay \%hash; - $record = create FS::cust_pay { 'column' => 'value' }; + $record = new FS::cust_pay \%hash; + $record = new FS::cust_pay { 'column' => 'value' }; $error = $record->insert; @@ -57,24 +55,13 @@ L<Time::Local> and L<Date::Parse> for conversion functions. =over 4 -=item create HASHREF +=item new HASHREF Creates a new payment. To add the payment to the databse, see L<"insert">. =cut -sub create { - my($proto,$hashref)=@_; - - #now in FS::Record::new - #my($field); - #foreach $field (fields('cust_pay')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('cust_pay',$hashref); - -} +sub table { 'cust_pay'; } =item insert @@ -84,31 +71,30 @@ L<FS::cust_bill>). =cut sub insert { - my($self)=@_; + my $self = shift; - my($error); + my $error; - $error=$self->check; + $error = $self->check; return $error if $error; - my($old_cust_bill) = qsearchs('cust_bill', { - 'invnum' => $self->getfield('invnum') - } ); + 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->getfield('paid') ); - my($new_cust_bill) = create FS::cust_bill ( \%hash ); + 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); + $error = $new_cust_bill->replace($old_cust_bill); return "Error modifying cust_bill: $error" if $error; - $self->add; + $self->SUPER::insert; } =item delete @@ -119,10 +105,6 @@ Currently unimplemented (accounting reasons). sub delete { return "Can't (yet?) delete cust_pay records!"; -#template code below -# my($self)=@_; -# -# $self->del; } =item replace OLD_RECORD @@ -133,12 +115,6 @@ Currently unimplemented (accounting reasons). sub replace { return "Can't (yet?) modify cust_pay records!"; -#template code below -# my($new,$old)=@_; -# return "(Old) Not a cust_pay record!" unless $old->table eq "cust_pay"; -# -# $new->check or -# $new->rep($old); } =item check @@ -149,61 +125,43 @@ returns the error, otherwise returns false. Called by the insert method. =cut sub check { - my($self)=@_; - return "Not a cust_pay record!" unless $self->table eq "cust_pay"; - my($recref) = $self->hashref; - - $recref->{paynum} =~ /^(\d*)$/ or return "Illegal paynum"; - $recref->{paynum} = $1; + my $self = shift; - $recref->{invnum} =~ /^(\d+)$/ or return "Illegal invnum"; - $recref->{invnum} = $1; + my $error; - $recref->{paid} =~ /^(\d+(\.\d\d)?)$/ or return "Illegal paid"; - $recref->{paid} = $1; - - $recref->{_date} =~ /^(\d*)$/ or return "Illegal date"; - $recref->{_date} = $recref->{_date} ? $1 : time; + $error = + $self->ut_numbern('paynum') + || $self->ut_number('invnum') + || $self->ut_money('paid') + || $self->ut_numbern('_date') + ; + return $error if $error; - $recref->{payby} =~ /^(CARD|BILL|COMP)$/ or return "Illegal payby"; - $recref->{payby} = $1; + $self->_date(time) unless $self->_date; - if ( $recref->{payby} eq 'CARD' ) { + $self->payby =~ /^(CARD|BILL|COMP)$/ or return "Illegal payby"; + $self->payby($1); - $recref->{payinfo} =~ s/\D//g; - if ( $recref->{payinfo} ) { - $recref->{payinfo} =~ /^(\d{13,16})$/ + 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)"; - $recref->{payinfo} = $1; - #validate($recref->{payinfo}) - # or return "Illegal credit card number"; - my($type)=cardtype($recref->{payinfo}); - return "Unknown credit card type" - unless ( $type =~ /^VISA/ || - $type =~ /^MasterCard/ || - $type =~ /^American Express/ || - $type =~ /^Discover/ ); + $self->payinfo($1); + validate($self->payinfo) or return "Illegal credit card number"; + return "Unknown card type" if cardtype($self->payinfo) eq "Unknown"; } else { - $recref->{payinfo}='N/A'; + $self->payinfo('N/A'); } - } elsif ( $recref->{payby} eq 'BILL' ) { - - $recref->{payinfo} =~ /^([\w \-]*)$/ - or return "Illegal P.O. number (payinfo)"; - $recref->{payinfo} = $1; - - } elsif ( $recref->{payby} eq 'COMP' ) { - - $recref->{payinfo} =~ /^([\w]{2,8})$/ - or return "Illegal comp account issuer (payinfo)"; - $recref->{payinfo} = $1; - + } else { + $error = $self->ut_textn('payinfo'); + return $error if $error; } - $recref->{paybatch} =~ /^([\w\-\:]*)$/ - or return "Illegal paybatch"; - $recref->{paybatch} = $1; + $error = $self->ut_textn('paybatch'); + return $error if $error; ''; #no error @@ -211,9 +169,11 @@ sub check { =back -=head1 BUGS +=head1 VERSION -It doesn't properly override FS::Record yet. +$Id: cust_pay.pm,v 1.3 1999-01-25 12:26:11 ivan Exp $ + +=head1 BUGS Delete and replace methods. @@ -229,6 +189,14 @@ new api ivan@sisd.com 98-mar-13 pod ivan@sisd.com 98-sep-21 +$Log: cust_pay.pm,v $ +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 new file mode 100644 index 000000000..f7350c116 --- /dev/null +++ b/site_perl/cust_pay_batch.pm @@ -0,0 +1,224 @@ +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<hash> 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($self->payinfo) eq "Unknown"; + + if ( $self->exp eq '' ) { + return "Expriation date required"; + $self->exp(''); + } else { + $self->exp =~ /^(\d{1,2})[\/\-](\d{2}(\d{2})?)$/ + or return "Illegal expiration date"; + 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"); + } + } + + 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 =~ /^([\w\-]{10})$/ or return "Illegal 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.3 1998-12-29 11:59:44 ivan Exp $ + +=head1 BUGS + +There should probably be a configuration file with a list of allowed credit +card types. + +=head1 SEE ALSO + +L<FS::cust_main>, L<FS::Record> + +=head1 HISTORY + +ivan@voicenet.com 97-jul-1 + +added hfields +ivan@sisd.com 97-nov-13 + +$Log: cust_pay_batch.pm,v $ +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 index 7dc5aa7ec..aa68f608f 100644 --- a/site_perl/cust_pkg.pm +++ b/site_perl/cust_pkg.pm @@ -2,12 +2,21 @@ package FS::cust_pkg; use strict; use vars qw(@ISA); -use Exporter; -use FS::UID qw(getotaker); -use FS::Record qw(fields qsearch qsearchs); +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; -@ISA = qw(FS::Record Exporter); +# 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 @@ -17,8 +26,8 @@ FS::cust_pkg - Object methods for cust_pkg objects use FS::cust_pkg; - $record = create FS::cust_pkg \%hash; - $record = create FS::cust_pkg { 'column' => 'value' }; + $record = new FS::cust_pkg \%hash; + $record = new FS::cust_pkg { 'column' => 'value' }; $error = $record->insert; @@ -34,6 +43,10 @@ FS::cust_pkg - Object methods for cust_pkg objects $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 ] ); @@ -72,36 +85,33 @@ conversion functions. =over 4 -=item create HASHREF +=item new HASHREF Create a new billing item. To add the item to the database, see L<"insert">. =cut -sub create { - my($proto,$hashref)=@_; - - #now in FS::Record::new - #my($field); - #foreach $field (fields('cust_pkg')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('cust_pkg',$hashref); -} +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. -=cut - sub insert { - my($self)=@_; + 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; - $self->check or - $self->add; } =item delete @@ -110,6 +120,8 @@ 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!"; } @@ -121,7 +133,7 @@ returns the error, otherwise returns false. Currently, custnum, setup, bill, susp, expire, and cancel may be changed. -pkgpart may not be changed, but see the order subroutine. +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<FS::cust_main>). @@ -134,21 +146,16 @@ in some cases). =cut sub replace { - my($new,$old)=@_; - return "(Old) Not a cust_pkg record!" if $old->table ne "cust_pkg"; - return "Can't change pkgnum!" - if $old->getfield('pkgnum') ne $new->getfield('pkgnum'); - return "Can't (yet?) change pkgpart!" - if $old->getfield('pkgpart') ne $new->getfield('pkgpart'); - return "Can't change otaker!" - if $old->getfield('otaker') ne $new->getfield('otaker'); + 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->check or - $new->rep($old); + $new->SUPER::replace($old); } =item check @@ -160,38 +167,30 @@ replace methods. =cut sub check { - my($self)=@_; - return "Not a cust_pkg record!" if $self->table ne "cust_pkg"; - my($recref) = $self->hashref; - - $recref->{pkgnum} =~ /^(\d*)$/ or return "Illegal pkgnum"; - $recref->{pkgnum}=$1; - - $recref->{custnum} =~ /^(\d+)$/ or return "Illegal custnum"; - $recref->{custnum}=$1; - return "Unknown customer" - unless qsearchs('cust_main',{'custnum'=>$recref->{custnum}}); + 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 } ); + } - $recref->{pkgpart} =~ /^(\d+)$/ or return "Illegal pkgpart"; - $recref->{pkgpart}=$1; return "Unknown pkgpart" - unless qsearchs('part_pkg',{'pkgpart'=>$recref->{pkgpart}}); - - $recref->{otaker} ||= &getotaker; - $recref->{otaker} =~ /^(\w{0,8})$/ or return "Illegal otaker"; - $recref->{otaker}=$1; - - $recref->{setup} =~ /^(\d*)$/ or return "Illegal setup date"; - $recref->{setup}=$1; + unless qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } ); - $recref->{bill} =~ /^(\d*)$/ or return "Illegal bill date"; - $recref->{bill}=$1; - - $recref->{susp} =~ /^(\d*)$/ or return "Illegal susp date"; - $recref->{susp}=$1; - - $recref->{cancel} =~ /^(\d*)$/ or return "Illegal cancel date"; - $recref->{cancel}=$1; + $self->otaker(getotaker) unless $self->otaker; + $self->otaker =~ /^(\w{0,16})$/ or return "Illegal otaker"; + $self->otaker($1); ''; #no error } @@ -207,47 +206,44 @@ If there is an error, returns the error, otherwise returns false. =cut sub cancel { - my($self)=@_; - my($error); + 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($cust_svc); - foreach $cust_svc ( - qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } ) + foreach my $cust_svc ( + qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ) { - my($part_svc)= - qsearchs('part_svc',{'svcpart'=> $cust_svc->svcpart } ); + my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } ); - $part_svc->getfield('svcdb') =~ /^([\w\-]+)$/ + $part_svc->svcdb =~ /^([\w\-]+)$/ or return "Illegal svcdb value in part_svc!"; - my($svcdb) = $1; + my $svcdb = $1; require "FS/$svcdb.pm"; - my($svc) = qsearchs($svcdb,{'svcnum' => $cust_svc->svcnum } ); + my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } ); if ($svc) { - bless($svc,"FS::$svcdb"); $error = $svc->cancel; return "Error cancelling service: $error" if $error; $error = $svc->delete; return "Error deleting service: $error" if $error; } - bless($cust_svc,"FS::cust_svc"); $error = $cust_svc->delete; return "Error deleting cust_svc: $error" if $error; } unless ( $self->getfield('cancel') ) { - my(%hash) = $self->hash; - $hash{'cancel'}=$^T; - my($new) = create FS::cust_pkg ( \%hash ); - $error=$new->replace($self); + my %hash = $self->hash; + $hash{'cancel'} = time; + my $new = new FS::cust_pkg ( \%hash ); + $error = $new->replace($self); return $error if $error; } @@ -264,30 +260,28 @@ If there is an error, returns the error, otherwise returns false. =cut sub suspend { - my($self)=@_; - my($error); + 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($cust_svc); - foreach $cust_svc ( - qsearch('cust_svc',{'pkgnum'=> $self->getfield('pkgnum') } ) + foreach my $cust_svc ( + qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ) { - my($part_svc)= - qsearchs('part_svc',{'svcpart'=> $cust_svc->getfield('svcpart') } ); + my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } ); - $part_svc->getfield('svcdb') =~ /^([\w\-]+)$/ + $part_svc->svcdb =~ /^([\w\-]+)$/ or return "Illegal svcdb value in part_svc!"; - my($svcdb) = $1; + my $svcdb = $1; require "FS/$svcdb.pm"; - my($svc) = qsearchs($svcdb,{'svcnum' => $cust_svc->getfield('svcnum') } ); - + my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } ); if ($svc) { - bless($svc,"FS::$svcdb"); $error = $svc->suspend; return $error if $error; } @@ -295,10 +289,10 @@ sub suspend { } unless ( $self->getfield('susp') ) { - my(%hash) = $self->hash; - $hash{'susp'}=$^T; - my($new) = create FS::cust_pkg ( \%hash ); - $error=$new->replace($self); + my %hash = $self->hash; + $hash{'susp'} = time; + my $new = new FS::cust_pkg ( \%hash ); + $error = $new->replace($self); return $error if $error; } @@ -315,7 +309,7 @@ If there is an error, returns the error, otherwise returns false. =cut sub unsuspend { - my($self)=@_; + my $self = shift; my($error); local $SIG{HUP} = 'IGNORE'; @@ -323,22 +317,20 @@ sub unsuspend { local $SIG{QUIT} = 'IGNORE'; local $SIG{TERM} = 'IGNORE'; local $SIG{TSTP} = 'IGNORE'; + local $SIG{PIPE} = 'IGNORE'; - my($cust_svc); - foreach $cust_svc ( - qsearch('cust_svc',{'pkgnum'=> $self->getfield('pkgnum') } ) + foreach my $cust_svc ( + qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } ) ) { - my($part_svc)= - qsearchs('part_svc',{'svcpart'=> $cust_svc->getfield('svcpart') } ); + my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } ); - $part_svc->getfield('svcdb') =~ /^([\w\-]+)$/ + $part_svc->svcdb =~ /^([\w\-]+)$/ or return "Illegal svcdb value in part_svc!"; - my($svcdb) = $1; + my $svcdb = $1; require "FS/$svcdb.pm"; - my($svc) = qsearchs($svcdb,{'svcnum' => $cust_svc->getfield('svcnum') } ); + my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } ); if ($svc) { - bless($svc,"FS::$svcdb"); $error = $svc->unsuspend; return $error if $error; } @@ -346,16 +338,40 @@ sub unsuspend { } unless ( ! $self->getfield('susp') ) { - my(%hash) = $self->hash; - $hash{'susp'}=''; - my($new) = create FS::cust_pkg ( \%hash ); - $error=$new->replace($self); + 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<FS::part_pkg). + +=cut + +sub part_pkg { + my $self = shift; + qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } ); +} + +=item labels + +Returns a list of lists, calling the label method for all services +(see L<FS::cust_svc>) of this billing item. + +=cut + +sub labels { + my $self = shift; + map { [ $_->label ] } qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } ); +} + =back =head1 SUBROUTINES @@ -437,38 +453,39 @@ sub order { 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}); - return "Package $pkgnum not found to remove!" unless $old; + die "Package $pkgnum not found to remove!" unless $old; my(%hash) = $old->hash; - $hash{'cancel'}=$^T; - my($new) = create FS::cust_pkg ( \%hash ); + $hash{'cancel'}=time; + my($new) = new FS::cust_pkg ( \%hash ); my($error)=$new->replace($old); - return $error if $error; + 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) = create FS::cust_pkg ( { + my($new) = new FS::cust_pkg ( { 'custnum' => $custnum, 'pkgpart' => $pkgpart, } ); my($error) = $new->insert; - return $error if $error; + 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) = create FS::cust_svc ( \%hash ); + my($new) = new FS::cust_svc ( \%hash ); my($error)=$new->replace($cust_svc); - return $error if $error; + die "Couldn't link old service to new package: $error" if $error; } } @@ -477,9 +494,11 @@ sub order { =back -=head1 BUGS +=head1 VERSION -It doesn't properly override FS::Record yet. +$Id: cust_pkg.pm,v 1.9 1999-03-29 01:11:51 ivan Exp $ + +=head1 BUGS sub order is not OO. Perhaps it should be moved to FS::cust_main and made so? @@ -488,6 +507,12 @@ 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<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc> @@ -501,6 +526,34 @@ 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.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 index a30f21716..4ec54907d 100644 --- a/site_perl/cust_refund.pm +++ b/site_perl/cust_refund.pm @@ -1,15 +1,13 @@ package FS::cust_refund; use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; +use vars qw( @ISA ); use Business::CreditCard; -use FS::Record qw(fields qsearchs); +use FS::Record qw( qsearchs ); use FS::UID qw(getotaker); use FS::cust_credit; -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); +@ISA = qw( FS::Record ); =head1 NAME @@ -19,8 +17,8 @@ FS::cust_refund - Object method for cust_refund objects use FS::cust_refund; - $record = create FS::cust_refund \%hash; - $record = create FS::cust_refund { 'column' => 'value' }; + $record = new FS::cust_refund \%hash; + $record = new FS::cust_refund { 'column' => 'value' }; $error = $record->insert; @@ -58,24 +56,13 @@ L<Time::Local> and L<Date::Parse> for conversion functions. =over 4 -=item create HASHREF +=item new HASHREF Creates a new refund. To add the refund to the database, see L<"insert">. =cut -sub create { - my($proto,$hashref)=@_; - - #now in FS::Record::new - #my($field); - #foreach $field (fields('cust_refund')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('cust_refund',$hashref); - -} +sub table { 'cust_refund'; } =item insert @@ -85,31 +72,31 @@ L<FS::cust_credit>). =cut sub insert { - my($self)=@_; + my $self = shift; - my($error); + my $error; $error=$self->check; return $error if $error; - my($old_cust_credit) = qsearchs('cust_credit', { - 'crednum' => $self->getfield('crednum') - } ); + 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->getfield('refund') ); - my($new_cust_credit) = create FS::cust_credit ( \%hash ); + 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); + $error = $new_cust_credit->replace($old_cust_credit); return "Error modifying cust_credit: $error" if $error; - $self->add; + $self->SUPER::insert; } =item delete @@ -120,10 +107,6 @@ Currently unimplemented (accounting reasons). sub delete { return "Can't (yet?) delete cust_refund records!"; -#template code below -# my($self)=@_; -# -# $self->del; } =item replace OLD_RECORD @@ -134,12 +117,6 @@ Currently unimplemented (accounting reasons). sub replace { return "Can't (yet?) modify cust_refund records!"; -#template code below -# my($new,$old)=@_; -# return "(Old) Not a cust_refund record!" unless $old->table eq "cust_refund"; -# -# $new->check or -# $new->rep($old); } =item check @@ -150,10 +127,11 @@ returns the error, otherwise returns false. Called by the insert method. =cut sub check { - my($self)=@_; - return "Not a cust_refund record!" unless $self->table eq "cust_refund"; + my $self = shift; + + my $error; - my $error = + $error = $self->ut_number('refundnum') || $self->ut_number('crednum') || $self->ut_money('amount') @@ -161,44 +139,27 @@ sub check { ; return $error if $error; - my($recref) = $self->hashref; + $self->_date(time) unless $self->_date; - $recref->{_date} ||= time; + $self->payby =~ /^(CARD|BILL|COMP)$/ or return "Illegal payby"; + $self->payby($1); - $recref->{payby} =~ /^(CARD|BILL|COMP)$/ or return "Illegal payby"; - $recref->{payby} = $1; - - if ( $recref->{payby} eq 'CARD' ) { - - $recref->{payinfo} =~ s/\D//g; - if ( $recref->{payinfo} ) { - $recref->{payinfo} =~ /^(\d{13,16})$/ + 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)"; - $recref->{payinfo} = $1; - #validate($recref->{payinfo}) - # or return "Illegal (checksum) credit card number (payinfo)"; - my($type)=cardtype($recref->{payinfo}); - return "Unknown credit card type" - unless ( $type =~ /^VISA/ || - $type =~ /^MasterCard/ || - $type =~ /^American Express/ || - $type =~ /^Discover/ ); + $self->payinfo($1); + validate($self->payinfo) or return "Illegal credit card number"; + return "Unknown card type" if cardtype($self->payinfo) eq "Unknown"; } else { - $recref->{payinfo}='N/A'; + $self->payinfo('N/A'); } - } elsif ( $recref->{payby} eq 'BILL' ) { - - $recref->{payinfo} =~ /^([\w \-]*)$/ - or return "Illegal P.O. number (payinfo)"; - $recref->{payinfo} = $1; - - } elsif ( $recref->{payby} eq 'COMP' ) { - - $recref->{payinfo} =~ /^([\w]{2,8})$/ - or return "Illegal comp account issuer (payinfo)"; - $recref->{payinfo} = $1; - + } else { + $error = $self->ut_textn('payinfo'); + return $error if $error; } $self->otaker(getotaker); @@ -208,9 +169,11 @@ sub check { =back -=head1 BUGS +=head1 VERSION + +$Id: cust_refund.pm,v 1.3 1999-01-25 12:26:13 ivan Exp $ -It doesn't properly override FS::Record yet. +=head1 BUGS Delete and replace methods. @@ -227,6 +190,14 @@ ivan@sisd.com 98-mar-18 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 index 1d5051b1f..f97f5fe9d 100644 --- a/site_perl/cust_svc.pm +++ b/site_perl/cust_svc.pm @@ -1,11 +1,17 @@ package FS::cust_svc; use strict; -use vars qw(@ISA); -use Exporter; -use FS::Record qw(fields qsearchs); - -@ISA = qw(FS::Record Exporter); +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 @@ -15,8 +21,8 @@ FS::cust_svc - Object method for cust_svc objects use FS::cust_svc; - $record = create FS::cust_svc \%hash - $record = create FS::cust_svc { 'column' => 'value' }; + $record = new FS::cust_svc \%hash + $record = new FS::cust_svc { 'column' => 'value' }; $error = $record->insert; @@ -26,6 +32,8 @@ FS::cust_svc - Object method for cust_svc objects $error = $record->check; + ($label, $value) = $record->label; + =head1 DESCRIPTION An FS::cust_svc represents a service. FS::cust_svc inherits from FS::Record. @@ -45,7 +53,7 @@ The following fields are currently supported: =over 4 -=item create HASHREF +=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 @@ -53,32 +61,13 @@ L<FS::svc_acct>, L<FS::svc_domain>, and L<FS::svc_acct_sm>, among others). =cut -sub create { - my($proto,$hashref)=@_; - - #now in FS::Record::new - #my($field); - #foreach $field (fields('cust_svc')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('cust_svc',$hashref); -} +sub table { 'cust_svc'; } =item insert Adds this service to the database. If there is an error, returns the error, otherwise returns false. -=cut - -sub insert { - my($self)=@_; - - $self->check or - $self->add; -} - =item delete Deletes this service from the database. If there is an error, returns the @@ -86,30 +75,11 @@ error, otherwise returns false. Called by the cancel method of the package (see L<FS::cust_pkg>). -=cut - -sub delete { - my($self)=@_; - # anything else here? - $self->del; -} - =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)=@_; - return "(Old) Not a cust_svc record!" unless $old->table eq "cust_svc"; - return "Can't change svcnum!" - unless $old->getfield('svcnum') eq $new->getfield('svcnum'); - $new->check or - $new->rep($old); -} - =item check Checks all fields to make sure this is a valid service. If there is an error, @@ -119,35 +89,72 @@ replace methods. =cut sub check { - my($self)=@_; - return "Not a cust_svc record!" unless $self->table eq "cust_svc"; - my($recref) = $self->hashref; + my $self = shift; - $recref->{svcnum} =~ /^(\d*)$/ or return "Illegal svcnum"; - $recref->{svcnum}=$1; + my $error = + $self->ut_numbern('svcnum') + || $self->ut_numbern('pkgnum') + || $self->ut_number('svcpart') + ; + return $error if $error; - $recref->{pkgnum} =~ /^(\d*)$/ or return "Illegal pkgnum"; - $recref->{pkgnum}=$1; - return "Unknown pkgnum" unless - ! $recref->{pkgnum} || - qsearchs('cust_pkg',{'pkgnum'=>$recref->{pkgnum}}); + return "Unknown pkgnum" + unless ! $self->pkgnum + || qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } ); - $recref->{svcpart} =~ /^(\d+)$/ or return "Illegal svcpart"; - $recref->{svcpart}=$1; return "Unknown svcpart" unless - qsearchs('part_svc',{'svcpart'=>$recref->{svcpart}}); + 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 checket in general (here). +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 @@ -162,6 +169,20 @@ 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_column.pm b/site_perl/dbdef_column.pm index 023b57d1f..dc07305b8 100644 --- a/site_perl/dbdef_column.pm +++ b/site_perl/dbdef_column.pm @@ -134,16 +134,21 @@ sub length { Returns an SQL column definition. -If passed a DBI $datasrc specifying L<DBD::mysql>, will use MySQL-specific -syntax. Non-standard syntax for other engines (if applicable) may also be -supported in the future. +If passed a DBI $datasrc specifying L<DBD::mysql> or L<DBD::Pg>, will use +engine-specific syntax. =cut sub line { my($self,$datasrc)=@_; my($null)=$self->null; - $null ||= "NOT NULL" if $datasrc =~ /mysql/; #yucky mysql hack + 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.')' : '' ), @@ -159,6 +164,10 @@ sub line { L<FS::dbdef_table>, L<FS::dbdef>, L<DBI> +=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 @@ -169,6 +178,14 @@ 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_table.pm b/site_perl/dbdef_table.pm index bc1454d9e..8c5bcfe77 100644 --- a/site_perl/dbdef_table.pm +++ b/site_perl/dbdef_table.pm @@ -202,12 +202,12 @@ sub sql_create_table { "CREATE TABLE ". $self->name. " ( ". join(", ", @columns). " )", ( map { - my($index) = $_ . "_index"; + my($index) = $self->name. "__". $_ . "_index"; $index =~ s/,\s*/_/g; "CREATE UNIQUE INDEX $index ON ". $self->name. " ($_)" } $self->unique->sql_list ), ( map { - my($index) = $_ . "_index"; + my($index) = $self->name. "__". $_ . "_index"; $index =~ s/,\s*/_/g; "CREATE INDEX $index ON ". $self->name. " ($_)" } $self->index->sql_list ), @@ -225,6 +225,10 @@ sub sql_create_table { L<FS::dbdef>, L<FS::dbdef_unique>, L<FS::dbdef_index>, L<FS::dbdef_unique>, L<DBI> +=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 @@ -243,6 +247,11 @@ 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/part_pkg.pm b/site_perl/part_pkg.pm index d1c12e47e..4b6cc09a4 100644 --- a/site_perl/part_pkg.pm +++ b/site_perl/part_pkg.pm @@ -1,12 +1,10 @@ package FS::part_pkg; use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(fields hfields); +use vars qw( @ISA ); +use FS::Record; -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(hfields fields); +@ISA = qw( FS::Record ); =head1 NAME @@ -16,8 +14,10 @@ FS::part_pkg - Object methods for part_pkg objects use FS::part_pkg; - $record = create FS::part_pkg \%hash - $record = create FS::part_pkg { 'column' => 'value' }; + $record = new FS::part_pkg \%hash + $record = new FS::part_pkg { 'column' => 'value' }; + + $custom_record = $template_record->clone; $error = $record->insert; @@ -29,8 +29,8 @@ FS::part_pkg - Object methods for part_pkg objects =head1 DESCRIPTION -An FS::part_pkg represents a billing item definition. FS::part_pkg inherits -from FS::Record. The following fields are currently supported: +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 @@ -55,23 +55,33 @@ just as you would normally. More advanced semantics are not yet defined. =over 4 -=item create HASHREF +=item new HASHREF Creates a new billing item definition. To add the billing item definition to the database, see L<"insert">. =cut -sub create { - my($proto,$hashref)=@_; +sub table { 'part_pkg'; } + +=item clone - #now in FS::Record::new - #my($field); - #foreach $field (fields('part_pkg')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} +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">. - $proto->new('part_pkg',$hashref); +=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 @@ -79,15 +89,6 @@ sub create { Adds this billing item definition to the database. If there is an error, returns the error, otherwise returns false. -=cut - -sub insert { - my($self)=@_; - - $self->check or - $self->add; -} - =item delete Currently unimplemented. @@ -96,10 +97,7 @@ Currently unimplemented. sub delete { return "Can't (yet?) delete package definitions."; -# maybe check & make sure the pkgpart isn't in cust_pkg or type_pkgs? -# my($self)=@_; -# -# $self->del; +# check & make sure the pkgpart isn't in cust_pkg or type_pkgs? } =item replace OLD_RECORD @@ -107,17 +105,6 @@ sub delete { 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)=@_; - return "(Old) Not a part_pkg record!" unless $old->table eq "part_pkg"; - return "Can't change pkgpart!" - unless $old->getfield('pkgpart') eq $new->getfield('pkgpart'); - $new->check or - $new->rep($old); -} - =item check Checks all fields to make sure this is a valid billing item definition. If @@ -127,21 +114,23 @@ insert and replace methods. =cut sub check { - my($self)=@_; - return "Not a part_pkg record!" unless $self->table eq "part_pkg"; + my $self = shift; $self->ut_numbern('pkgpart') - or $self->ut_text('pkg') - or $self->ut_text('comment') - or $self->ut_anything('setup') - or $self->ut_number('freq') - or $self->ut_anything('recur') + || $self->ut_text('pkg') + || $self->ut_text('comment') + || $self->ut_anything('setup') + || $self->ut_number('freq') + || $self->ut_anything('recur') ; - } =back +=head1 VERSION + +$Id: part_pkg.pm,v 1.5 1998-12-31 01:04:16 ivan Exp $ + =head1 BUGS It doesn't properly override FS::Record yet. @@ -162,6 +151,14 @@ ivan@sisd.com 97-dec-5 pod ivan@sisd.com 98-sep-21 +$Log: part_pkg.pm,v $ +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 index 1b4a1b65a..e63e822a8 100644 --- a/site_perl/part_referral.pm +++ b/site_perl/part_referral.pm @@ -1,12 +1,10 @@ package FS::part_referral; use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(fields qsearchs); +use vars qw( @ISA ); +use FS::Record; -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); +@ISA = qw( FS::Record ); =head1 NAME @@ -16,8 +14,8 @@ FS::part_referral - Object methods for part_referral objects use FS::part_referral; - $record = create FS::part_referral \%hash - $record = create FS::part_referral { 'column' => 'value' }; + $record = new FS::part_referral \%hash + $record = new FS::part_referral { 'column' => 'value' }; $error = $record->insert; @@ -46,38 +44,19 @@ following fields are currently supported: =over 4 -=item create HASHREF +=item new HASHREF Creates a new referral. To add the referral to the database, see L<"insert">. =cut -sub create { - my($proto,$hashref)=@_; - - #now in FS::Record::new - #my($field); - #foreach $field (fields('part_referral')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('part_referral',$hashref); -} +sub table { 'part_referral'; } =item insert Adds this referral to the database. If there is an error, returns the error, otherwise returns false. -=cut - -sub insert { - my($self)=@_; - - $self->check or - $self->add; -} - =item delete Currently unimplemented. @@ -85,9 +64,9 @@ Currently unimplemented. =cut sub delete { - my($self)=@_; + my $self = shift; return "Can't (yet?) delete part_referral records"; - #$self->del; + #need to make sure no customers have this referral! } =item replace OLD_RECORD @@ -95,18 +74,6 @@ sub delete { 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)=@_; - return "(Old) Not an part_referral record!" - unless $old->table eq "part_referral"; - return "Can't change refnum!" - unless $old->getfield('refnum') eq $new->getfield('refnum'); - $new->check or - $new->rep($old); -} - =item check Checks all fields to make sure this is a valid referral. If there is an error, @@ -116,24 +83,20 @@ methods. =cut sub check { - my($self)=@_; - return "Not a part_referral record!" unless $self->table eq "part_referral"; + my $self = shift; - my($error)= - $self->ut_numbern('refnum') - or $self->ut_text('referral') + $self->ut_numbern('refnum') + || $self->ut_text('referral') ; - return $error if $error; - - ''; - } =back -=head1 BUGS +=head1 VERSION -It doesn't properly override FS::Record yet. +$Id: part_referral.pm,v 1.2 1998-12-29 11:59:49 ivan Exp $ + +=head1 BUGS The delete method is unimplemented. @@ -149,6 +112,11 @@ 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 index 0fd8ee47d..6b3ba3d9f 100644 --- a/site_perl/part_svc.pm +++ b/site_perl/part_svc.pm @@ -1,12 +1,10 @@ package FS::part_svc; use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(fields hfields); +use vars qw( @ISA ); +use FS::Record qw( fields ); -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(hfields fields); +@ISA = qw(FS::Record); =head1 NAME @@ -16,8 +14,8 @@ FS::part_svc - Object methods for part_svc objects use FS::part_svc; - $record = create FS::part_referral \%hash - $record = create FS::part_referral { 'column' => 'value' }; + $record = new FS::part_referral \%hash + $record = new FS::part_referral { 'column' => 'value' }; $error = $record->insert; @@ -51,39 +49,20 @@ L<FS::svc_domain>, and L<FS::svc_acct_sm>, among others. =over 4 -=item create HASHREF +=item new HASHREF Creates a new service definition. To add the service definition to the database, see L<"insert">. =cut -sub create { - my($proto,$hashref)=@_; - - #now in FS::Record::new - #my($field); - #foreach $field (fields('part_svc')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('part_svc',$hashref); -} +sub table { 'part_svc'; } =item insert Adds this service definition to the database. If there is an error, returns the error, otherwise returns false. -=cut - -sub insert { - my($self)=@_; - - $self->check or - $self->add; -} - =item delete Currently unimplemented. @@ -92,10 +71,7 @@ Currently unimplemented. sub delete { return "Can't (yet?) delete service definitions."; -# maybe check & make sure the svcpart isn't in cust_svc or (in any packages)? -# my($self)=@_; -# -# $self->del; +# check & make sure the svcpart isn't in cust_svc or pkg_svc (in any packages)? } =item replace OLD_RECORD @@ -106,14 +82,12 @@ returns the error, otherwise returns false. =cut sub replace { - my($new,$old)=@_; - return "(Old) Not a part_svc record!" unless $old->table eq "part_svc"; - return "Can't change svcpart!" - unless $old->getfield('svcpart') eq $new->getfield('svcpart'); + my ( $new, $old ) = ( shift, shift ); + return "Can't change svcdb!" - unless $old->getfield('svcdb') eq $new->getfield('svcdb'); - $new->check or - $new->rep($old); + unless $old->svcdb eq $new->svcdb; + + $new->SUPER::replace( $old ); } =item check @@ -125,30 +99,29 @@ and replace methods. =cut sub check { - my($self)=@_; - return "Not a part_svc record!" unless $self->table eq "part_svc"; - my($recref) = $self->hashref; + my $self = shift; + my $recref = $self->hashref; - my($error); - return $error if $error= + 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 + my @fields = eval { fields( $recref->{svcdb} ) }; #might die return "Unknown svcdb!" unless @fields; - my($svcdb); + my $svcdb; foreach $svcdb ( qw( - svc_acct svc_acct_sm svc_charge svc_domain svc_wo + svc_acct svc_acct_sm svc_domain ) ) { - my(@rows)=map { /^${svcdb}__(.*)$/; $1 } + my @rows = map { /^${svcdb}__(.*)$/; $1 } grep ! /_flag$/, grep /^${svcdb}__/, fields('part_svc'); - my($row); - foreach $row (@rows) { + foreach my $row (@rows) { unless ( $svcdb eq $recref->{svcdb} ) { $recref->{$svcdb.'__'.$row}=''; $recref->{$svcdb.'__'.$row.'_flag'}=''; @@ -158,11 +131,8 @@ sub check { or return "Illegal flag for $svcdb $row"; $recref->{$svcdb.'__'.$row.'_flag'} = $1; -# $recref->{$svcdb.'__'.$row} =~ /^(.*)$/ #not restrictive enough? -# or return "Illegal value for $svcdb $row"; -# $recref->{$svcdb.'__'.$row} = $1; - my($error); - return $error if $error=$self->ut_anything($svcdb.'__'.$row); + my $error = $self->ut_anything($svcdb.'__'.$row); + return $error if $error; } } @@ -172,12 +142,17 @@ sub check { =back -=head1 BUGS +=head1 VERSION -It doesn't properly override FS::Record yet. +$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<FS::Record>, L<FS::part_pkg>, L<FS::pkg_svc>, L<FS::cust_svc>, @@ -193,6 +168,14 @@ 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 index 517125c01..ee4ad629e 100644 --- a/site_perl/pkg_svc.pm +++ b/site_perl/pkg_svc.pm @@ -1,12 +1,10 @@ package FS::pkg_svc; use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(fields hfields qsearchs); +use vars qw( @ISA ); +use FS::Record qw( qsearchs ); -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(hfields); +@ISA = qw( FS::Record ); =head1 NAME @@ -16,8 +14,8 @@ FS::pkg_svc - Object methods for pkg_svc records use FS::pkg_svc; - $record = create FS::pkg_svc \%hash; - $record = create FS::pkg_svc { 'column' => 'value' }; + $record = new FS::pkg_svc \%hash; + $record = new FS::pkg_svc { 'column' => 'value' }; $error = $record->insert; @@ -48,52 +46,24 @@ definition includes =over 4 -=item create HASHREF +=item new HASHREF Create a new record. To add the record to the database, see L<"insert">. =cut -sub create { - my($proto,$hashref)=@_; - - #now in FS::Record::new - #my($field); - #foreach $field (fields('pkg_svc')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('pkg_svc',$hashref); - -} +sub table { 'pkg_svc'; } =item insert Adds this record to the database. If there is an error, returns the error, otherwise returns false. -=cut - -sub insert { - my($self)=@_; - - $self->check or - $self->add; -} - =item delete Deletes this record from the database. If there is an error, returns the error, otherwise returns false. -=cut - -sub delete { - my($self)=@_; - - $self->del; -} - =item replace OLD_RECORD Replaces OLD_RECORD with this one in the database. If there is an error, @@ -102,15 +72,12 @@ returns the error, otherwise returns false. =cut sub replace { - my($new,$old)=@_; - return "(Old) Not a pkg_svc record!" unless $old->table eq "pkg_svc"; - return "Can't change pkgpart!" - if $old->getfield('pkgpart') ne $new->getfield('pkgpart'); - return "Can't change svcpart!" - if $old->getfield('svcpart') ne $new->getfield('svcpart'); - - $new->check or - $new->rep($old); + 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 @@ -122,31 +89,32 @@ methods. =cut sub check { - my($self)=@_; - return "Not a pkg_svc record!" unless $self->table eq "pkg_svc"; - my($recref) = $self->hashref; + my $self = shift; - my($error); - return $error if $error = + my $error; + $error = $self->ut_number('pkgpart') || $self->ut_number('svcpart') || $self->ut_number('quantity') ; + return $error if $error; return "Unknown pkgpart!" - unless qsearchs('part_pkg',{'pkgpart'=> $self->getfield('pkgpart')}); + unless qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } ); return "Unknown svcpart!" - unless qsearchs('part_svc',{'svcpart'=> $self->getfield('svcpart')}); + unless qsearchs('part_svc', { 'svcpart' => $self->svcpart } ); ''; #no error } =back -=head1 BUGS +=head1 VERSION -It doesn't properly override FS::Record yet. +$Id: pkg_svc.pm,v 1.3 1999-01-18 21:58:08 ivan Exp $ + +=head1 BUGS =head1 SEE ALSO @@ -162,6 +130,14 @@ ivan@sisd.com 97-nov-13 pod ivan@sisd.com 98-sep-22 +$Log: pkg_svc.pm,v $ +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 new file mode 100644 index 000000000..f53e83e48 --- /dev/null +++ b/site_perl/svc_Common.pm @@ -0,0 +1,217 @@ +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<FS::cust_svc>) 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<FS::part_svc>). 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<FS::part_svc>), 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<FS::cust_pkg>). + +=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<FS::Record>, L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, 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 index a43af6b1a..f066ebdd6 100644 --- a/site_perl/svc_acct.pm +++ b/site_perl/svc_acct.pm @@ -1,21 +1,24 @@ package FS::svc_acct; use strict; -use vars qw(@ISA @EXPORT_OK $nossh_hack $conf $dir_prefix @shells +use vars qw(@ISA $nossh_hack $conf $dir_prefix @shells $shellmachine @saltset @pw_set); -use Exporter; use FS::Conf; -use FS::Record qw(fields qsearchs); +use FS::Record qw( qsearchs fields ); +use FS::svc_Common; use FS::SSH qw(ssh); -use FS::cust_svc; +use FS::part_svc; +use FS::svc_acct_pop; -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); +@ISA = qw( FS::svc_Common ); -$conf = new FS::Conf; -$dir_prefix = $conf->config('home'); -@shells = $conf->config('shells'); -$shellmachine = $conf->config('shellmachine'); +#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', '(', ')', '#', '!', '.', ',' ); @@ -30,8 +33,8 @@ FS::svc_acct - Object methods for svc_acct records use FS::svc_acct; - $record = create FS::svc_acct \%hash; - $record = create FS::svc_acct { 'column' => 'value' }; + $record = new FS::svc_acct \%hash; + $record = new FS::svc_acct { 'column' => 'value' }; $error = $record->insert; @@ -50,7 +53,7 @@ FS::svc_acct - Object methods for svc_acct records =head1 DESCRIPTION An FS::svc_acct object represents an account. FS::svc_acct inherits from -FS::Record. The following fields are currently supported: +FS::svc_Common. The following fields are currently supported: =over 4 @@ -84,24 +87,13 @@ FS::Record. The following fields are currently supported: =over 4 -=item create HASHREF +=item new HASHREF Creates a new account. To add the account to the database, see L<"insert">. =cut -sub create { - my($proto,$hashref)=@_; - - #now in FS::Record::new - #my($field); - #foreach $field (fields('svc_acct')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('svc_acct',$hashref); - -} +sub table { 'svc_acct'; } =item insert @@ -122,50 +114,34 @@ setting $FS::svc_acct::nossh_hack true. =cut sub insert { - my($self)=@_; - my($error); + 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; + $error = $self->check; return $error if $error; return "Username ". $self->username. " in use" - if qsearchs('svc_acct',{'username'=> $self->username } ); + if qsearchs( 'svc_acct', { 'username' => $self->username } ); - my($part_svc) = qsearchs('part_svc',{ 'svcpart' => $self->svcpart }); + 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 } ) + && qsearchs( 'svc_acct', { 'uid' => $self->uid } ) && $self->username !~ /^(hyla)?fax$/ ; - my($svcnum)=$self->svcnum; - my($cust_svc); - unless ( $svcnum ) { - $cust_svc=create FS::cust_svc ( { - 'svcnum' => $svcnum, - 'pkgnum' => $self->pkgnum, - 'svcpart' => $self->svcpart, - } ); - my($error) = $cust_svc->insert; - return $error if $error; - $svcnum = $self->svcnum($cust_svc->svcnum); - } - - $error = $self->add; - if ($error) { - #$cust_svc->del if $cust_svc; - $cust_svc->delete if $cust_svc; - return $error; - } + $error = $self->SUPER::insert; + return $error if $error; - my($username,$uid,$dir,$shell) = ( + my ( $username, $uid, $dir, $shell ) = ( $self->username, $self->uid, $self->dir, @@ -207,25 +183,20 @@ setting $FS::svc_acct::nossh_hack true. =cut sub delete { - my($self)=@_; - my($error); + 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->getfield('svcnum'); - - $error = $self->del; + $error = $self->SUPER::delete; return $error if $error; - my($cust_svc)=qsearchs('cust_svc',{'svcnum'=>$svcnum}); - $error = $cust_svc->del; - return $error if $error; - - my($username) = $self->getfield('username'); + my $username = $self->username; if ( $username && $shellmachine && ! $nossh_hack ) { ssh("root\@$shellmachine","userdel $username"); } @@ -258,39 +229,30 @@ setting $FS::svc_acct::nossh_hack true. =cut sub replace { - my($new,$old)=@_; - my($error); - - return "(Old) Not a svc_acct record!" unless $old->table eq "svc_acct"; - return "Can't change svcnum!" - unless $old->getfield('svcnum') eq $new->getfield('svcnum'); + my ( $new, $old ) = ( shift, shift ); + my $error; return "Username in use" - if $old->getfield('username') ne $new->getfield('username') && - qsearchs('svc_acct',{'username'=> $new->getfield('username') } ); + if $old->username ne $new->username && + qsearchs( 'svc_acct', { 'username' => $new->username } ); - return "Can't change uid!" - if $old->getfield('uid') ne $new->getfield('uid'); + return "Can't change uid!" if $old->uid != $new->uid; #change homdir when we change username - if ( $old->getfield('username') ne $new->getfield('username') ) { - $new->setfield('dir',''); - } - - $error=$new->check; - return $error if $error; + $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->rep($old); + $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') ); + 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 @@ -319,17 +281,15 @@ Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>). =cut sub suspend { - my($old) = @_; - my(%hash) = $old->hash; + my $self = shift; + my %hash = $self->hash; unless ( $hash{_password} =~ /^\*SUSPENDED\* / ) { $hash{_password} = '*SUSPENDED* '.$hash{_password}; - my($new) = create FS::svc_acct ( \%hash ); -# $new->replace($old); - $new->rep($old); #to avoid password checking :) + my $new = new FS::svc_acct ( \%hash ); + $new->replace($self); } else { ''; #no error (already suspended) } - } =item unsuspend @@ -342,13 +302,12 @@ Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>). =cut sub unsuspend { - my($old) = @_; - my(%hash) = $old->hash; + my $self = shift; + my %hash = $self->hash; if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) { $hash{_password} = $1; - my($new) = create FS::svc_acct ( \%hash ); -# $new->replace($old); - $new->rep($old); #to avoid password checking :) + my $new = new FS::svc_acct ( \%hash ); + $new->replace($self); } else { ''; #no error (already unsuspended) } @@ -360,13 +319,6 @@ Just returns false (no error) for now. Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>). -=cut - -# Usage: $error = $record -> cancel; -sub cancel { - ''; #stub (no error) - taken care of in delete -} - =item check Checks all fields to make sure this is a valid service. If there is an error, @@ -378,35 +330,15 @@ Sets any fixed values; see L<FS::part_svc>. =cut sub check { - my($self)=@_; - return "Not a svc_acct record!" unless $self->table eq "svc_acct"; - my($recref) = $self->hashref; - - $recref->{svcnum} =~ /^(\d*)$/ or return "Illegal svcnum"; - $recref->{svcnum} = $1; + my $self = shift; - #get part_svc - my($svcpart); - my($svcnum)=$self->getfield('svcnum'); - if ($svcnum) { - my($cust_svc)=qsearchs('cust_svc',{'svcnum'=>$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; + my($recref) = $self->hashref; - #set fixed fields from part_svc - my($field); - foreach $field ( fields('svc_acct') ) { - if ( $part_svc->getfield('svc_acct__'. $field. '_flag') eq 'F' ) { - $self->setfield($field,$part_svc->getfield('svc_acct__'. $field) ); - } - } + my $x = $self->setfixed; + return $x unless ref($x); + my $part_svc = $x; - my($ulen)=$self->dbdef_table->column('username')->length; + my $ulen =$self->dbdef_table->column('username')->length; $recref->{username} =~ /^([a-z0-9_\-]{2,$ulen})$/ or return "Illegal username"; $recref->{username} = $1; @@ -511,20 +443,23 @@ sub check { =back -=head1 BUGS +=head1 VERSION -It doesn't properly override FS::Record yet. +$Id: svc_acct.pm,v 1.7 1999-04-07 14:37:37 ivan Exp $ + +=head1 BUGS The remote commands should be configurable. -The create method should set defaults from part_svc (like the check method -sets fixed values). +The bits which ssh should fork before doing so. + +The $recref stuff in sub check should be cleaned up. =head1 SEE ALSO -L<FS::Record>, L<FS::Conf>, L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, -L<FS::SSH>, L<ssh>, L<FS::svc_acct_pop>, schema.html from the base -documentation. +L<FS::svc_Common>, L<FS::Record>, L<FS::Conf>, L<FS::cust_svc>, +L<FS::part_svc>, L<FS::cust_pkg>, L<FS::SSH>, L<ssh>, L<FS::svc_acct_pop>, +schema.html from the base documentation. =head1 HISTORY @@ -551,6 +486,24 @@ arbitrary radius attributes ivan@sisd.com 98-aug-13 pod and FS::conf ivan@sisd.com 98-sep-22 +$Log: svc_acct.pm,v $ +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 index a6f801f22..fe2b5f3ac 100644 --- a/site_perl/svc_acct_pop.pm +++ b/site_perl/svc_acct_pop.pm @@ -1,12 +1,10 @@ package FS::svc_acct_pop; use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(fields qsearchs); +use vars qw( @ISA ); +use FS::Record qw( qsearchs ); -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); +@ISA = qw( FS::Record ); =head1 NAME @@ -16,8 +14,8 @@ FS::svc_acct_pop - Object methods for svc_acct_pop records use FS::svc_acct_pop; - $record = create FS::svc_acct_pop \%hash; - $record = create FS::svc_acct_pop { 'column' => 'value' }; + $record = new FS::svc_acct_pop \%hash; + $record = new FS::svc_acct_pop { 'column' => 'value' }; $error = $record->insert; @@ -50,68 +48,29 @@ inherits from FS::Record. The following fields are currently supported: =over 4 -=item create HASHREF +=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 create { - my($proto,$hashref)=@_; - - #now in FS::Record::new - #my($field); - #foreach $field (fields('svc_acct_pop')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('svc_acct_pop',$hashref); -} +sub table { 'svc_acct_pop'; } =item insert -Adds this point of presence to the databaes. If there is an error, returns the +Adds this point of presence to the database. If there is an error, returns the error, otherwise returns false. -=cut - -sub insert { - my($self)=@_; - - $self->check or - $self->add; -} - =item delete -Currently unimplemented. - -=cut - -sub delete { - my($self)=@_; - return "Can't (yet) delete POPs!"; - #$self->del; -} +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. -=cut - -sub replace { - my($new,$old)=@_; - return "(Old) Not an svc_acct_pop record!" - unless $old->table eq "svc_acct_pop"; - return "Can't change popnum!" - unless $old->getfield('popnum') eq $new->getfield('popnum'); - $new->check or - $new->rep($old); -} - =item check Checks all fields to make sure this is a valid point of presence. If there is @@ -121,27 +80,24 @@ and replace methods. =cut sub check { - my($self)=@_; - return "Not a svc_acct_pop record!" unless $self->table eq "svc_acct_pop"; + my $self = shift; - my($error)= $self->ut_numbern('popnum') or $self->ut_text('city') or $self->ut_text('state') or $self->ut_number('ac') or $self->ut_number('exch') ; - return $error if $error; - - ''; } =back -=head1 BUGS +=head1 VERSION + +$Id: svc_acct_pop.pm,v 1.2 1998-12-29 11:59:53 ivan Exp $ -It doesn't properly override FS::Record yet. +=head1 BUGS It should be renamed to part_pop. @@ -157,6 +113,11 @@ 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 index c87ed2c54..c757ab073 100644 --- a/site_perl/svc_acct_sm.pm +++ b/site_perl/svc_acct_sm.pm @@ -1,21 +1,24 @@ package FS::svc_acct_sm; use strict; -use vars qw(@ISA @EXPORT_OK $nossh_hack $conf $shellmachine @qmailmachines); -use Exporter; -use FS::Record qw(fields qsearch qsearchs); +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::Record Exporter); -@EXPORT_OK = qw(fields); +@ISA = qw( FS::svc_Common ); -$conf = new FS::Conf; - -$shellmachine = $conf->exists('qmailmachines') - ? $conf->config('shellmachine') - : ''; +#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 @@ -25,8 +28,8 @@ FS::svc_acct_sm - Object methods for svc_acct_sm records use FS::svc_acct_sm; - $record = create FS::svc_acct_sm \%hash; - $record = create FS::svc_acct_sm { 'column' => 'value' }; + $record = new FS::svc_acct_sm \%hash; + $record = new FS::svc_acct_sm { 'column' => 'value' }; $error = $record->insert; @@ -63,25 +66,14 @@ from FS::Record. The following fields are currently supported: =over 4 -=item create HASHREF +=item new HASHREF Creates a new virtual mail alias. To add the virtual mail alias to the database, see L<"insert">. =cut -sub create { - my($proto,$hashref)=@_; - - #now in FS::Record::new - #my($field); - #foreach $field (fields('svc_acct_sm')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('svc_acct_sm',$hashref); - -} +sub table { 'svc_acct_sm'; } =item insert @@ -105,14 +97,15 @@ This behaviour can be surpressed by setting $FS::svc_acct_sm::nossh_hack true. =cut sub insert { - my($self)=@_; - my($error); + 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; @@ -127,34 +120,18 @@ sub insert { if $self->domuser ne '*' && ! qsearch('svc_acct_sm',{ 'domsvc' => $self->domsvc } ); - my($svcnum)=$self->getfield('svcnum'); - my($cust_svc); - unless ( $svcnum ) { - $cust_svc=create FS::cust_svc ( { - 'svcnum' => $svcnum, - 'pkgnum' => $self->getfield('pkgnum'), - 'svcpart' => $self->getfield('svcpart'), - } ); - my($error) = $cust_svc->insert; - return $error if $error; - $svcnum = $self->setfield('svcnum',$cust_svc->getfield('svcnum')); - } - - $error = $self->add; - if ($error) { - $cust_svc->del if $cust_svc; - return $error; - } + $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->getfield('uid'), - $svc_acct->getfield('gid'), - $svc_acct->getfield('dir'), - $svc_domain->getfield('domain') + 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; + 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 '*' ); @@ -170,25 +147,6 @@ returns the error, otherwise returns false. The corresponding FS::cust_svc record will be deleted as well. -=cut - -sub delete { - my($self)=@_; - my($error); - - my($svcnum)=$self->getfield('svcnum'); - - $error = $self->del; - return $error if $error; - - my($cust_svc)=qsearchs('cust_svc',{'svcnum'=>$svcnum}); - $error = $cust_svc->del; - return $error if $error; - - ''; - -} - =item replace OLD_RECORD Replaces OLD_RECORD with this one in the database. If there is an error, @@ -197,29 +155,20 @@ returns the error, otherwise returns false. =cut sub replace { - my($new,$old)=@_; - my($error); - - return "(Old) Not a svc_acct_sm record!" unless $old->table eq "svc_acct_sm"; - return "Can't change svcnum!" - unless $old->getfield('svcnum') eq $new->getfield('svcnum'); + 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 ne $new->domsvc + || $old->domsvc != $new->domsvc ) && qsearchs('svc_acct_sm',{ 'domuser'=> $new->domuser, 'domsvc' => $new->domsvc, } ) ; - $error=$new->check; - return $error if $error; - - $error = $new->rep($old); - return $error if $error; + $new->SUPER::replace($old); - ''; #no error } =item suspend @@ -228,36 +177,18 @@ Just returns false (no error) for now. Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>). -=cut - -sub suspend { - ''; #no error (stub) -} - =item unsuspend Just returns false (no error) for now. Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>). -=cut - -sub unsuspend { - ''; #no error (stub) -} - =item cancel Just returns false (no error) for now. Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>). -=cut - -sub cancel { - ''; #no error (stub) -} - =item check Checks all fields to make sure this is a valid virtual mail alias. If there is @@ -269,33 +200,14 @@ Sets any fixed values; see L<FS::part_svc>. =cut sub check { - my($self)=@_; - return "Not a svc_acct_sm record!" unless $self->table eq "svc_acct_sm"; - my($recref) = $self->hashref; + my $self = shift; + my $error; - $recref->{svcnum} =~ /^(\d*)$/ or return "Illegal svcnum"; - $recref->{svcnum} = $1; - - #get part_svc - my($svcpart); - my($svcnum)=$self->getfield('svcnum'); - if ($svcnum) { - my($cust_svc)=qsearchs('cust_svc',{'svcnum'=>$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 fixed fields from part_svc - my($field); - foreach $field ( fields('svc_acct_sm') ) { - if ( $part_svc->getfield('svc_acct_sm__'. $field. '_flag') eq 'F' ) { - $self->setfield($field,$part_svc->getfield('svc_acct_sm__'. $field) ); - } - } + 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)"; @@ -318,12 +230,16 @@ sub check { =back -=head1 BUGS +=head1 VERSION -It doesn't properly override FS::Record yet. +$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<FS::Record>, L<FS::Conf>, L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, diff --git a/site_perl/svc_domain.pm b/site_perl/svc_domain.pm index 1ddd5b290..19aac3f88 100644 --- a/site_perl/svc_domain.pm +++ b/site_perl/svc_domain.pm @@ -1,73 +1,48 @@ package FS::svc_domain; use strict; -use vars qw(@ISA @EXPORT_OK $whois_hack $conf $mydomain $smtpmachine); -use Exporter; +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 FS::Record qw(fields qsearch qsearchs); -use FS::cust_svc; use FS::Conf; - -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); - -$conf = new FS::Conf; - -$mydomain = $conf->config('domain'); -$smtpmachine = $conf->config('smtpmachine'); - -my($internic)="/var/spool/freeside/conf/registries/internic"; -my($conf_tech)="$internic/tech_contact"; -my($conf_from)="$internic/from"; -my($conf_to)="$internic/to"; -my($nameservers)="$internic/nameservers"; -my($template)="$internic/template"; - -open(TECH_CONTACT,$conf_tech) or die "Can't open $conf_tech: $!"; -my($tech_contact)=map { - /^(.*)$/ or die "Illegal line in $conf_tech!"; #yes, we trust the file - $1; -} grep $_ !~ /^(#|$)/, <TECH_CONTACT>; -close TECH_CONTACT; - -open(FROM,$conf_from) or die "Can't open $conf_from: $!"; -my($from)=map { - /^(.*)$/ or die "Illegal line in $conf_from!"; #yes, we trust the file - $1; -} grep $_ !~ /^(#|$)/, <FROM>; -close FROM; - -open(TO,$conf_to) or die "Can't open $conf_to: $!"; -my($to)=map { - /^(.*)$/ or die "Illegal line in $conf_to!"; #yes, we trust the file - $1; -} grep $_ !~ /^(#|$)/, <TO>; -close TO; - -open(NAMESERVERS,$nameservers) or die "Can't open $nameservers: $!"; -my(@nameservers)=map { - /^\s*\d+\.\d+\.\d+\.\d+\s+([^\s]+)\s*$/ - or die "Illegal line in $nameservers!"; #yes, we trust the file - $1; -} grep $_ !~ /^(#|$)/, <NAMESERVERS>; -close NAMESERVERS; -open(NAMESERVERS,$nameservers) or die "Can't open $nameservers: $!"; -my(@nameserver_ips)=map { - /^\s*(\d+\.\d+\.\d+\.\d+)\s+([^\s]+)\s*$/ - or die "Illegal line in $nameservers!"; #yes, we trust the file - $1; -} grep $_ !~ /^(#|$)/, <NAMESERVERS>; -close NAMESERVERS; - -open(TEMPLATE,$template) or die "Can't open $template: $!"; -my(@template)=map { - /^(.*)$/ or die "Illegal line in $to!"; #yes, we trust the file - $1. "\n"; -} <TEMPLATE>; -close TEMPLATE; +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 @@ -77,8 +52,8 @@ FS::svc_domain - Object methods for svc_domain records use FS::svc_domain; - $record = create FS::svc_domain \%hash; - $record = create FS::svc_domain { 'column' => 'value' }; + $record = new FS::svc_domain \%hash; + $record = new FS::svc_domain { 'column' => 'value' }; $error = $record->insert; @@ -97,7 +72,7 @@ FS::svc_domain - Object methods for svc_domain records =head1 DESCRIPTION An FS::svc_domain object represents a domain. FS::svc_domain inherits from -FS::Record. The following fields are currently supported: +FS::svc_Common. The following fields are currently supported: =over 4 @@ -111,24 +86,13 @@ FS::Record. The following fields are currently supported: =over 4 -=item create HASHREF +=item new HASHREF Creates a new domain. To add the domain to the database, see L<"insert">. =cut -sub create { - my($proto,$hashref)=@_; - - #now in FS::Record::new - #my($field); - #foreach $field (fields('svc_domain')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('svc_domain',$hashref); - -} +sub table { 'svc_domain'; } =item insert @@ -144,48 +108,38 @@ for transfers. A registration or transfer email will be submitted unless $FS::svc_domain::whois_hack is true. +The additional field I<email> can be used to manually set the admin contact +email address on this email. Otherwise, the svc_acct records for this package +(see L<FS::cust_pkg>) 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)=@_; - my($error); + 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; + $error = $self->check; return $error if $error; return "Domain in use (here)" - if qsearchs('svc_domain',{'domain'=> $self->domain } ); + if qsearchs( 'svc_domain', { 'domain' => $self->domain } ); - my($whois)=(($self->_whois)[0]); + my $whois = ($self->_whois)[0]; return "Domain in use (see whois)" if ( $self->action eq "N" && $whois !~ /^No match for/ ); return "Domain not found (see whois)" if ( $self->action eq "M" && $whois =~ /^No match for/ ); - my($svcnum)=$self->getfield('svcnum'); - my($cust_svc); - unless ( $svcnum ) { - $cust_svc=create FS::cust_svc ( { - 'svcnum' => $svcnum, - 'pkgnum' => $self->getfield('pkgnum'), - 'svcpart' => $self->getfield('svcpart'), - } ); - my($error) = $cust_svc->insert; - return $error if $error; - $svcnum = $self->setfield('svcnum',$cust_svc->getfield('svcnum')); - } - - $error = $self->add; - if ($error) { - $cust_svc->del if $cust_svc; - return $error; - } + $error = $self->SUPER::insert; + return $error if $error; $self->submit_internic unless $whois_hack; @@ -199,24 +153,6 @@ error, otherwise returns false. The corresponding FS::cust_svc record will be deleted as well. -=cut - -sub delete { - my($self)=@_; - my($error); - - my($svcnum)=$self->getfield('svcnum'); - - $error = $self->del; - return $error if $error; - - my($cust_svc)=qsearchs('cust_svc',{'svcnum'=>$svcnum}); - $error = $cust_svc->del; - return $error if $error; - - ''; -} - =item replace OLD_RECORD Replaces OLD_RECORD with this one in the database. If there is an error, @@ -225,29 +161,13 @@ returns the error, otherwise returns false. =cut sub replace { - my($new,$old)=@_; - my($error); - - return "(Old) Not a svc_domain record!" unless $old->table eq "svc_domain"; - return "Can't change svcnum!" - unless $old->getfield('svcnum') eq $new->getfield('svcnum'); + my ( $new, $old ) = ( shift, shift ); + my $error; return "Can't change domain - reorder." if $old->getfield('domain') ne $new->getfield('domain'); - $error=$new->check; - return $error if $error; - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - - $error = $new->rep($old); - return $error if $error; - - ''; + $new->SUPER::replace($old); } @@ -257,36 +177,18 @@ Just returns false (no error) for now. Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>). -=cut - -sub suspend { - ''; #no error (stub) -} - =item unsuspend Just returns false (no error) for now. Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>). -=cut - -sub unsuspend { - ''; #no error (stub) -} - =item cancel Just returns false (no error) for now. Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>). -=cut - -sub cancel { - ''; #no error (stub) -} - =item check Checks all fields to make sure this is a valid domain. If there is an error, @@ -298,46 +200,34 @@ Sets any fixed values; see L<FS::part_svc>. =cut sub check { - my($self)=@_; - return "Not a svc_domain record!" unless $self->table eq "svc_domain"; - my($recref) = $self->hashref; - - $recref->{svcnum} =~ /^(\d*)$/ or return "Illegal svcnum"; - $recref->{svcnum} = $1; - - #get part_svc (and pkgnum) - my($svcpart,$pkgnum); - my($svcnum)=$self->getfield('svcnum'); - if ($svcnum) { - my($cust_svc)=qsearchs('cust_svc',{'svcnum'=>$svcnum}); - return "Unknown svcnum" unless $cust_svc; - $svcpart=$cust_svc->svcpart; - $pkgnum=$cust_svc->pkgnum; + 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 { - $svcpart=$self->svcpart; - $pkgnum=$self->pkgnum; - } - my($part_svc)=qsearchs('part_svc',{'svcpart'=>$svcpart}); - return "Unkonwn svcpart" unless $part_svc; - - #set fixed fields from part_svc - my($field); - foreach $field ( fields('svc_acct') ) { - if ( $part_svc->getfield('svc_domain__'. $field. '_flag') eq 'F' ) { - $self->setfield($field,$part_svc->getfield('svc_domain__'. $field) ); - } + $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}); + 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 first"; + 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 { @@ -378,10 +268,10 @@ $FS::svc_domain::whois_hack is set true.) =cut sub _whois { - my($self)=@_; - my($domain)=$self->domain; + my $self = shift; + my $domain = $self->domain; return ( "No match for domain \"$domain\"." ) if $whois_hack; - open(WHOIS,"whois do $domain |"); + open(WHOIS, "whois do $domain |"); return <WHOIS>; } @@ -392,14 +282,14 @@ Submits a registration email for this domain. =cut sub submit_internic { - my($self)=@_; + my $self = shift; - my($cust_pkg)=qsearchs('cust_pkg',{'pkgnum'=>$self->pkgnum}); + my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } ); return unless $cust_pkg; - my($cust_main)=qsearchs('cust_main',{'custnum'=>$cust_pkg->custnum}); + my $cust_main = qsearchs( 'cust_main', { 'custnum' => $cust_pkg->custnum } ); return unless $cust_main; - my(%subs)=( + my %subs = ( 'action' => $self->action, 'purpose' => $self->purpose, 'domain' => $self->domain, @@ -422,18 +312,18 @@ sub submit_internic { ); #yuck - my(@xtemplate)=@template; - my(@body); - my($line); - OLOOP: while ( defined($line = shift @xtemplate) ) { + my @xtemplate = @template; + my @body; + my $line; + OLOOP: while ( defined( $line = shift @xtemplate ) ) { if ( $line =~ /^###LOOP###$/ ) { my(@buffer); - LOADBUF: while ( defined($line = shift @xtemplate) ) { + LOADBUF: while ( defined( $line = shift @xtemplate ) ) { last LOADBUF if ( $line =~ /^###ENDLOOP###$/ ); push @buffer, $line; } - my(%lubs)=( + my %lubs = ( 'address' => $cust_main->address2 ? [ $cust_main->address1, $cust_main->address2 ] : [ $cust_main->address1 ] @@ -442,8 +332,8 @@ sub submit_internic { 'secondary_ip' => [ @nameserver_ips ], ); LOOP: while (1) { - my(@xbuffer)=@buffer; - SUBLOOP: while ( defined($line = shift @xbuffer) ) { + 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}}; @@ -467,23 +357,23 @@ sub submit_internic { } #OLOOP - my($subject); + my $subject; if ( $self->action eq "M" ) { $subject = "MODIFY DOMAIN ". $self->domain; - } elsif ($self->action eq "N" ) { + } 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( [ + $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), + "Date: ". time2str("%a, %d %b %Y %X %z", time), "Subject: $subject", ] ); @@ -498,23 +388,26 @@ sub submit_internic { =back -=head1 BUGS +=head1 VERSION -It doesn't properly override FS::Record yet. +$Id: svc_domain.pm,v 1.7 1999-04-07 14:40:15 ivan Exp $ + +=head1 BUGS All BIND/DNS fields should be included (and exported). -All registries should be supported. +Delete doesn't send a registration template. -Not all configuration access is through FS::Conf! +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<FS::Record>, L<FS::Conf>, L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, -L<FS::SSH>, L<ssh>, L<dot-qmail>, schema.html from the base documentation, -config.html from the base documentation. +L<FS::svc_Common>, L<FS::Record>, L<FS::Conf>, L<FS::cust_svc>, +L<FS::part_svc>, L<FS::cust_pkg>, L<FS::SSH>, L<ssh>, L<dot-qmail>, schema.html from the base documentation, config.html from the base documentation. =head1 HISTORY @@ -532,6 +425,24 @@ 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.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 index a8cbaed5e..40c9ed9b5 100644 --- a/site_perl/table_template-svc.pm +++ b/site_perl/table_template-svc.pm @@ -1,107 +1,177 @@ -#!/usr/local/bin/perl -Tw -# -# ivan@voicenet.com 97-jul-21 - package FS::svc_table; use strict; -use Exporter; -use FS::Record qw(fields qsearchs); +use vars qw(@ISA); +#use FS::Record qw( qsearch qsearchs ); +use FS::svc_Common; +use FS::cust_svc; -@FS::svc_table::ISA = qw(FS::Record Exporter); +@ISA = qw(svc_Common); -# Usage: $record = create FS::svc_table ( \%hash ); -# $record = create FS::svc_table ( { field=>value, ... } ); -sub create { - my($proto,$hashref)=@_; +=head1 NAME - my($field); - foreach $field (fields('svc_table')) { - $hashref->{$field}='' unless defined $hashref->{$field}; - } +FS::table_name - Object methods for table_name records - $proto->new('svc_table',$hashref); +=head1 SYNOPSIS -} + use FS::table_name; -# Usage: $error = $record -> insert; -sub insert { - my($self)=@_; - my($error); + $record = new FS::table_name \%hash; + $record = new FS::table_name { 'column' => 'value' }; - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; + $error = $record->insert; - $error=$self->check; - return $error if $error; + $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 - $error = $self->add; +=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<hash> 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<FS::cust_svc>) 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; - ''; #no error + ''; } -# Usage: $error = $record -> delete; +=item delete + +Delete this record from the database. + +=cut + sub delete { - my($self)=@_; - my($error); + my $self = shift; + my $error; - $error = $self->del; + $error = $self->SUPER::delete; return $error if $error; + ''; } -# Usage: $error = $newrecord -> replace($oldrecord) -sub replace { - my($new,$old)=@_; - my($error); - return "(Old) Not a svc_table record!" unless $old->table eq "svc_table"; - return "Can't change svcnum!" - unless $old->getfield('svcnum') eq $new->getfield('svcnum'); +=item replace OLD_RECORD - $error=$new->check; - return $error if $error; +Replaces the OLD_RECORD with this one in the database. If there is an error, +returns the error, otherwise returns false. + +=cut - $error = $new->rep($old); +sub replace { + my ( $new, $old ) = ( shift, shift ); + my $error; + + $error = $new->SUPER::replace($old); return $error if $error; - ''; #no error + ''; } -# Usage: $error = $record -> suspend; -sub suspend { - ''; #no error (stub) -} +=item suspend -# Usage: $error = $record -> unsuspend; -sub unsuspend { - ''; #no error (stub) -} +Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>). -# Usage: $error = $record -> cancel; -sub cancel { - ''; #no error (stub) -} +=item unsuspend + +Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>). + +=item cancel + +Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>). + +=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 -# Usage: $error = $record -> check; sub check { - my($self)=@_; - return "Not a svc_table record!" unless $self->table eq "svc_table"; - my($recref) = $self->hashref; + my $self = shift; - $recref->{svcnum} =~ /^(\d+)$/ or return "Illegal svcnum"; - $recref->{svcnum} = $1; - return "Unknown svcnum" unless - qsearchs('cust_svc',{'svcnum'=> $recref->{svcnum} } ); + my $x = $self->setfixed; + return $x unless ref($x); + my $part_svc = $x; - #DATA CHECKS GO HERE! ''; #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<FS::svc_Common>, L<FS::Record>, L<FS::cust_svc>, L<FS::part_svc>, +L<FS::cust_pkg>, 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-unique.pm b/site_perl/table_template-unique.pm deleted file mode 100644 index 32b7e6911..000000000 --- a/site_perl/table_template-unique.pm +++ /dev/null @@ -1,66 +0,0 @@ -#!/usr/local/bin/perl -Tw -# -# ivan@voicenet.com 97-jul-1 -# -# added hfields -# ivan@sisd.com 97-nov-13 - -package FS::table_name; - -use strict; -use Exporter; -#use FS::UID qw(getotaker); -use FS::Record qw(fields hfields qsearch qsearchs); - -@FS::table_name::ISA = qw(FS::Record Exporter); -@FS::table_name::EXPORT_OK = qw(hfields); - -# Usage: $record = create FS::table_name ( \%hash ); -# $record = create FS::table_name ( { field=>value, ... } ); -sub create { - my($proto,$hashref)=@_; - - my($field); - foreach $field (fields('table_name')) { - $hashref->{$field}='' unless defined $hashref->{$field}; - } - - $proto->new('table_name',$hashref); -} - -# Usage: $error = $record -> insert; -sub insert { - my($self)=@_; - - $self->check or - $self->add; -} - -# Usage: $error = $record -> delete; -sub delete { - my($self)=@_; - - $self->del; -} - -# Usage: $error = $newrecord -> replace($oldrecord) -sub replace { - my($new,$old)=@_; - return "(Old) Not a table_name record!" unless $old->table eq "table_name"; - return "Can't change keyfield!" - unless $old->getfield('keyfield') eq $new->getfield('keyfield'); - $new->check or - $new->rep($old); -} - -# Usage: $error = $record -> check; -sub check { - my($self)=@_; - return "Not a table_name record!" unless $self->table eq "table_name"; - my($recref) = $self->hashref; - - ''; #no error -} - -1; - diff --git a/site_perl/table_template.pm b/site_perl/table_template.pm index cef2d92e8..0173bc5cf 100644 --- a/site_perl/table_template.pm +++ b/site_perl/table_template.pm @@ -1,66 +1,134 @@ -#!/usr/local/bin/perl -Tw -# -# ivan@voicenet.com 97-jul-1 -# -# added hfields -# ivan@sisd.com 97-nov-13 - package FS::table_name; use strict; -use Exporter; -#use FS::UID qw(getotaker); -use FS::Record qw(hfields qsearch qsearchs); +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); -@FS::table_name::ISA = qw(FS::Record Exporter); -@FS::table_name::EXPORT_OK = qw(hfields); +@ISA = qw(FS::Record); -# Usage: $record = create FS::table_name ( \%hash ); -# $record = create FS::table_name ( { field=>value, ... } ); -sub create { - my($proto,$hashref)=@_; +=head1 NAME - my($field); - foreach $field (fields('table_name')) { - $hashref->{$field}='' unless defined $hashref->{$field}; - } +FS::table_name - Object methods for table_name records - $proto->new('table_name',$hashref); +=head1 SYNOPSIS -} + use FS::table_name; -# Usage: $error = $record -> insert; -sub insert { - my($self)=@_; + $record = new FS::table_name \%hash; + $record = new FS::table_name { 'column' => 'value' }; - $self->check or - $self->add; -} + $error = $record->insert; -# Usage: $error = $record -> delete; -sub delete { - my($self)=@_; + $error = $new_record->replace($old_record); - $self->del; -} + $error = $record->delete; -# Usage: $error = $newrecord -> replace($oldrecord) -sub replace { - my($new,$old)=@_; - return "(Old) Not a table_name record!" unless $old->table eq "table_name"; + $error = $record->check; - $new->check or - $new->rep($old); -} +=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<hash> 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 -# Usage: $error = $record -> check; sub check { - my($self)=@_; - return "Not a table_name record!" unless $self->table eq "table_name"; - my($recref) = $self->hashref; + 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<FS::Record>, 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 index a71579603..e19345e7c 100644 --- a/site_perl/type_pkgs.pm +++ b/site_perl/type_pkgs.pm @@ -1,12 +1,12 @@ package FS::type_pkgs; use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(fields qsearchs); +use vars qw( @ISA ); +use FS::Record qw( qsearchs ); +use FS::agent_type; +use FS::part_pkg; -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); +@ISA = qw( FS::Record ); =head1 NAME @@ -16,8 +16,8 @@ FS::type_pkgs - Object methods for type_pkgs records use FS::type_pkgs; - $record = create FS::type_pkgs \%hash; - $record = create FS::type_pkgs { 'column' => 'value' }; + $record = new FS::type_pkgs \%hash; + $record = new FS::type_pkgs { 'column' => 'value' }; $error = $record->insert; @@ -45,67 +45,29 @@ FS::Record. The following fields are currently supported: =over 4 -=item create HASHREF +=item new HASHREF Create a new record. To add the record to the database, see L<"insert">. =cut -sub create { - my($proto,$hashref)=@_; - - #now in FS::Record::new - #my($field); - #foreach $field (fields('type_pkgs')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('type_pkgs',$hashref); - -} +sub table { 'type_pkgs'; } =item insert Adds this record to the database. If there is an error, returns the error, otherwise returns false. -=cut - -sub insert { - my($self)=@_; - - $self->check or - $self->add; -} - =item delete Deletes this record from the database. If there is an error, returns the error, otherwise returns false. -=cut - -sub delete { - my($self)=@_; - - $self->del; -} - =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)=@_; - return "(Old) Not a type_pkgs record!" unless $old->table eq "type_pkgs"; - - $new->check or - $new->rep($old); -} - =item check Checks all fields to make sure this is a valid record. If there is an error, @@ -115,25 +77,36 @@ methods. =cut sub check { - my($self)=@_; - return "Not a type_pkgs record!" unless $self->table eq "type_pkgs"; - my($recref) = $self->hashref; + my $self = shift; + + my $error = + $self->ut_number('typenum') + || $self->ut_number('pkgpart') + ; + return $error if $error; - $recref->{typenum} =~ /^(\d+)$/ or return "Illegal typenum"; - $recref->{typenum} = $1; return "Unknown typenum" - unless qsearchs('agent_type',{'typenum'=>$recref->{typenum}}); + unless qsearchs( 'agent_type', { 'typenum' => $self->typenum } ); - $recref->{pkgpart} =~ /^(\d+)$/ or return "Illegal pkgpart"; - $recref->{pkgpart} = $1; return "Unknown pkgpart" - unless qsearchs('part_pkg',{'pkgpart'=>$recref->{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<FS::Record>, L<FS::agent_type>, L<FS::part_pkgs>, schema.html from the base +documentation. + =head1 HISTORY Defines the relation between agent types and pkgparts @@ -144,6 +117,11 @@ 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; |