diff options
Diffstat (limited to 'site_perl')
36 files changed, 0 insertions, 8429 deletions
diff --git a/site_perl/Bill.pm b/site_perl/Bill.pm deleted file mode 100644 index 4d7e059..0000000 --- a/site_perl/Bill.pm +++ /dev/null @@ -1,44 +0,0 @@ -package FS::Bill; - -use strict; -use vars qw(@ISA); -use FS::cust_main; - -@ISA = qw(FS::cust_main); - -warn "FS::Bill depriciated\n"; - -=head1 NAME - -FS::Bill - Legacy stub - -=head1 SYNOPSIS - -The functionality of FS::Bill has been integrated into FS::cust_main. - -=head1 HISTORY - -ivan@voicenet.com 97-jul-24 - 25 - 28 - -use Safe; evaluate all fees with perl (still on TODO list until I write -some examples & test opmask to see if we can read db) -%hash=$obj->hash later ivan@sisd.com 98-mar-13 - -packages with no next bill date start at $time not time, this should -eliminate the last of the problems with billing at a past date -also rewrite the invoice priting logic not to print invoices for things -that haven't happended yet and update $cust_bill->printed when we print -so PAST DUE notices work, and s/date/_date/ -ivan@sisd.com 98-jun-4 - -more logic for past due stuff - packages with no next bill date start -at $cust_pkg->setup || $time ivan@sisd.com 98-jul-13 - -moved a few things in collection logic; negative charges should work -ivan@sisd.com 98-aug-6 - -pod, moved everything to FS::cust_main ivan@sisd.com 98-sep-19 - -=cut - -1; diff --git a/site_perl/CGI.pm b/site_perl/CGI.pm deleted file mode 100644 index d2ed521..0000000 --- a/site_perl/CGI.pm +++ /dev/null @@ -1,143 +0,0 @@ -package FS::CGI; - -use strict; -use vars qw(@EXPORT_OK @ISA); -use Exporter; -use CGI::Base; -use CGI::Carp qw(fatalsToBrowser); - -@ISA = qw(Exporter); -@EXPORT_OK = qw(header menubar idiot eidiot); - -=head1 NAME - -FS::CGI - Subroutines for the web interface - -=head1 SYNOPSIS - - use FS::CGI qw(header menubar idiot eidiot); - - print header( 'Title', '' ); - print header( 'Title', menubar('item', 'URL', ... ) ); - - idiot "error message"; - eidiot "error message"; - -=head1 DESCRIPTION - -Provides a few common subroutines for the web interface. - -=head1 SUBROUTINES - -=over 4 - -=item header TITLE, MENUBAR - -Returns an HTML header. - -=cut - -sub header { - my($title,$menubar)=@_; - - <<END; - <HTML> - <HEAD> - <TITLE> - $title - </TITLE> - </HEAD> - <BODY> - <CENTER> - <H1> - $title - </H1> - $menubar - </CENTER> - <HR> -END -} - -=item menubar ITEM, URL, ... - -Returns an HTML menubar. - -=cut - -sub menubar { #$menubar=menubar('Main Menu', '../', 'Item', 'url', ... ); - my($item,$url,@html); - while (@_) { - ($item,$url)=splice(@_,0,2); - push @html, qq!<A HREF="$url">$item</A>!; - } - join(' | ',@html); -} - -=item idiot ERROR - -Sends headers and an HTML error message. - -=cut - -sub idiot { - my($error)=@_; - CGI::Base::SendHeaders(); - print <<END; -<HTML> - <HEAD> - <TITLE>Error processing your request</TITLE> - </HEAD> - <BODY> - <CENTER> - <H4>Error processing your request</H4> - </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 - -} - -=item eidiot ERROR - -Sends headers and an HTML error message, then exits. - -=cut - -sub eidiot { - idiot(@_); - exit; -} - -=back - -=head1 BUGS - -Not OO. - -Not complete. - -Uses CGI-modules instead of CGI.pm - -=head1 SEE ALSO - -L<CGI::Base> - -=head1 HISTORY - -subroutines for the HTML/CGI GUI, not properly OO. :( - -ivan@sisd.com 98-apr-16 -ivan@sisd.com 98-jun-22 - -lose the background, eidiot ivan@sisd.com 98-sep-2 - -pod ivan@sisd.com 98-sep-12 - -=cut - -1; - - diff --git a/site_perl/Conf.pm b/site_perl/Conf.pm deleted file mode 100644 index d3ef307..0000000 --- a/site_perl/Conf.pm +++ /dev/null @@ -1,113 +0,0 @@ -package FS::Conf; - -use vars qw($default_dir); -use IO::File; - -$default_dir='/var/spool/freeside/conf'; - -=head1 NAME - -FS::Conf - Read access to Freeside configuration values - -=head1 SYNOPSIS - - use FS::Conf; - - $conf = new FS::Conf; - $conf = new FS::Conf "/non/standard/config/directory"; - - $dir = $conf->dir; - - $value = $conf->config('key'); - @list = $conf->config('key'); - $bool = $conf->exists('key'); - -=head1 DESCRIPTION - -Read access to Freeside configuration values. Keys currently map to filenames, -but this may change in the future. - -=head1 METHODS - -=over 4 - -=item new [ DIRECTORY ] - -Create a new configuration object. Optionally, a non-default directory may -be specified. - -=cut - -sub new { - my($proto,$dir) = @_; - my($class) = ref($proto) || $proto; - my($self) = { 'dir' => $dir || $default_dir } ; - bless ($self, $class); -} - -=item dir - -Returns the directory. - -=cut - -sub dir { - my($self) = @_; - $self->{dir}; -} - -=item config - -Returns the configuration value or values (depending on context) for key. - -=cut - -sub config { - my($self,$file)=@_; - my($dir)=$self->dir; - my $fh = new IO::File "<$dir/$file" or return; - if ( wantarray ) { - map { - /^(.*)$/ or die "Illegal line in $dir/$file:\n$_\n"; - $1; - } <$fh>; - } else { - <$fh> =~ /^(.*)$/ or die "Illegal line in $dir/$file:\n$_\n"; - $1; - } -} - -=item exists - -Returns true if the specified key exists, even if the corresponding value -is undefined. - -=cut - -sub exists { - my($self,$file)=@_; - my($dir) = $self->dir; - -e "$dir/$file"; -} - -=back - -=head1 BUGS - -The option to specify a non-default directory should probably be removed. - -Write access (with locking) should be implemented. - -=head1 SEE ALSO - -config.html from the base documentation contains a list of configuration files. - -=head1 HISTORY - -Ivan Kohler <ivan@sisd.com> 98-sep-6 - -sub exists forgot to fetch $dir ivan@sisd.com 98-sep-27 - -=cut - -1; diff --git a/site_perl/Invoice.pm b/site_perl/Invoice.pm deleted file mode 100644 index 5eb596f..0000000 --- a/site_perl/Invoice.pm +++ /dev/null @@ -1,45 +0,0 @@ -package FS::Invoice; - -use strict; -use vars qw(@ISA); -use FS::cust_bill; - -@ISA = qw(FS::cust_bill); - -#warn "FS::Invoice depriciated\n"; - -=head1 NAME - -FS::Invoice - Legacy stub - -=head1 SYNOPSIS - -The functioanlity of FS::invoice has been integrated in FS::cust_bill. - -=head1 HISTORY - -ivan@voicenet.com 97-jun-25 - 27 - -maybe should be changed to be OO-functions on $cust_bill objects? -(instead of passing invnum, ugh). - -ISA cust_bill and return inovice instead of passing filehandle -ivan@sisd.com 98-mar-13 - -(add postscript output!) - -close our kid when we're done ivan@sisd.com 98-jun-4 - -separated code which shuffled data from code which formatted. -(so i could) fixed past due notices showing up when balance due =< 0 -return address comes from /var/spool/freeside/conf/address -ivan@sisd.com 98-jul-2 - -pod ivan@sisd.com 98-sep-20something - -s/ISA/@ISA/ in use vars ivan@sisd.com 98-sep-27 - -=cut - -1; - diff --git a/site_perl/Record.pm b/site_perl/Record.pm deleted file mode 100644 index 9b30850..0000000 --- a/site_perl/Record.pm +++ /dev/null @@ -1,868 +0,0 @@ -package FS::Record; - -use strict; -use vars qw($dbdef_file $dbdef $setup_hack $AUTOLOAD @ISA @EXPORT_OK); -use subs qw(reload_dbdef); -use Exporter; -use Carp; -use File::CounterFile; -use FS::UID qw(dbh checkruid swapuid getotaker datasrc); -use FS::dbdef; - -@ISA = qw(Exporter); -@EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef); - -$File::CounterFile::DEFAULT_DIR = "/var/spool/freeside/counters" ; - -$dbdef_file = "/var/spool/freeside/dbdef.". datasrc; - -reload_dbdef unless $setup_hack; - -=head1 NAME - -FS::Record - Database record objects - -=head1 SYNOPSIS - - use FS::Record; - use FS::Record qw(dbh fields hfields qsearch qsearchs dbdef); - - $record = new FS::Record 'table', \%hash; - $record = new FS::Record 'table', { 'column' => 'value', ... }; - - $record = qsearchs FS::Record 'table', \%hash; - $record = qsearchs FS::Record 'table', { 'column' => 'value', ... }; - @records = qsearch FS::Record 'table', \%hash; - @records = qsearch FS::Record 'table', { 'column' => 'value', ... }; - - $table = $record->table; - $dbdef_table = $record->dbdef_table; - - $value = $record->get('column'); - $value = $record->getfield('column'); - $value = $record->column; - - $record->set( 'column' => 'value' ); - $record->setfield( 'column' => 'value' ); - $record->column('value'); - - %hash = $record->hash; - - $hashref = $record->hashref; - - $error = $record->add; - - $error = $record->del; - - $error = $new_record->rep($old_record); - - $value = $record->unique('column'); - - $value = $record->ut_float('column'); - $value = $record->ut_number('column'); - $value = $record->ut_numbern('column'); - $value = $record->ut_money('column'); - $value = $record->ut_text('column'); - $value = $record->ut_textn('column'); - $value = $record->ut_alpha('column'); - $value = $record->ut_alphan('column'); - $value = $record->ut_phonen('column'); - $value = $record->ut_anythingn('column'); - - $dbdef = reload_dbdef; - $dbdef = reload_dbdef "/non/standard/filename"; - $dbdef = dbdef; - - $quoted_value = _quote($value,'table','field'); - - #depriciated - $fields = hfields('table'); - if ( $fields->{Field} ) { # etc. - - @fields = fields 'table'; - - -=head1 DESCRIPTION - -(Mostly) object-oriented interface to database records. Records are currently -implemented on top of DBI. FS::Record is intended as a base class for -table-specific classes to inherit from, i.e. FS::cust_main. - -=head1 METHODS - -=over 4 - -=item new TABLE, HASHREF - -Creates a new record. It doesn't store it in the database, though. See -L<"add"> for that. - -Note that the object stores this hash reference, not a distinct copy of the -hash it points to. You can ask the object for a copy with the I<hash> -method. - -=cut - -sub new { - my($proto,$table,$hashref) = @_; - confess "Second arguement to FS::Record->new is not a HASH ref: ", - ref($hashref), " ", $hashref, "\n" - unless ref($hashref) eq 'HASH'; #bad practice? - - #check to make sure $table exists? (ask dbdef) - - foreach my $field ( FS::Record::fields $table ) { - $hashref->{$field}='' unless defined $hashref->{$field}; - } - - # mySQL must rtrim the inbound text strings or store them z-terminated - # I simulate this for Postgres below - # Turned off in favor of ChopBlanks in UID.pm (see man DBI) - #if (datasrc =~ m/Pg/) - #{ - # foreach my $index (keys %$hashref) - # { - # $$hashref{$index} = unpack("A255", $$hashref{$index}) - # if ($$hashref{$index} =~ m/ $/) ; - # } - #} - - foreach my $column (keys %{$hashref}) { - #trim the '$' from money fields for Pg (beong HERE?) - #(what about Pg i18n?) - if ( datasrc =~ m/Pg/ - && $dbdef->table($table)->column($column)->type eq 'money' ) { - ${$hashref}{$column} =~ s/^\$//; - } - #foreach my $column ( grep $dbdef->table($table)->column($_)->type eq 'money', keys %{$hashref} ) { - # ${$hashref}{$column} =~ s/^\$//; - #} - } - - my $class = ref($proto) || $proto; - my $self = { 'Table' => $table, - 'Hash' => $hashref, - }; - - bless ($self, $class); - -} - -=item qsearch TABLE, HASHREF - -Searches the database for all records matching (at least) the key/value pairs -in HASHREF. Returns all the records found as FS::Record objects. - -=cut - -# Usage: @records = &FS::Search::qsearch($table,\%hash); -# Each element of @records is a FS::Record object. -sub qsearch { - my($table,$record) = @_; - my($dbh) = dbh; - - my(@fields)=grep exists($record->{$_}), fields($table); - - my($sth); - my($statement) = "SELECT * FROM $table". ( @fields - ? " WHERE ". join(' AND ', - map("$_ = ". _quote($record->{$_},$table,$_), @fields) - ) - : '' - ); - $sth=$dbh->prepare($statement) - or croak $dbh->errstr; #is that a little too harsh? hmm. - - map { - new FS::Record ($table,$sth->fetchrow_hashref); - } ( 1 .. $sth->execute ); - -} - -=item qsearchs TABLE, HASHREF - -Searches the database for a record matching (at least) the key/value pairs -in HASHREF, and returns the record found as an FS::Record object. If more than -one record matches, it 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; - #should warn more vehemently if the search was on a primary key? - $result[0]; -} - -=item table - -Returns the table name. - -=cut - -sub table { - my($self) = @_; - $self -> {'Table'}; -} - -=item dbdef_table - -Returns the FS::dbdef_table object for the table. - -=cut - -sub dbdef_table { - my($self)=@_; - my($table)=$self->table; - $dbdef->table($table); -} - -=item get, getfield COLUMN - -Returns the value of the column/field/key COLUMN. - -=cut - -sub get { - my($self,$field) = @_; - # to avoid "Use of unitialized value" errors - if ( defined ( $self->{Hash}->{$field} ) ) { - $self->{Hash}->{$field}; - } else { - ''; - } -} -sub getfield { - get(@_); -} - -=item set, setfield COLUMN, VALUE - -Sets the value of the column/field/key COLUMN to VALUE. Returns VALUE. - -=cut - -sub set { - my($self,$field,$value) = @_; - $self->{'Hash'}->{$field} = $value; -} -sub setfield { - set(@_); -} - -=item AUTLOADED METHODS - -$record->column is a synonym for $record->get('column'); - -$record->column('value') is a synonym for $record->set('column','value'); - -=cut - -sub AUTOLOAD { - my($self,$value)=@_; - my($field)=$AUTOLOAD; - $field =~ s/.*://; - if ( defined($value) ) { - $self->setfield($field,$value); - } else { - $self->getfield($field); - } -} - -=item hash - -Returns a list of the column/value pairs, usually for assigning to a new hash. - -To make a distinct duplicate of an FS::Record object, you can do: - - $new = new FS::Record ( $old->table, { $old->hash } ); - -=cut - -sub hash { - my($self) = @_; - %{ $self->{'Hash'} }; -} - -=item hashref - -Returns a reference to the column/value hash. - -=cut - -sub hashref { - my($self) = @_; - $self->{'Hash'}; -} - -=item add - -Adds this record to the database. If there is an error, returns the error, -otherwise returns false. - -=cut - -sub add { - my($self) = @_; - my($dbh)=dbh; - my($table)=$self->table; - - #single-field unique keys are given a value if false - #(like MySQL's AUTO_INCREMENT) - foreach ( $dbdef->table($table)->unique->singles ) { - $self->unique($_) unless $self->getfield($_); - } - #and also the primary key - my($primary_key)=$dbdef->table($table)->primary_key; - $self->unique($primary_key) - if $primary_key && ! $self->getfield($primary_key); - - my (@fields) = - grep defined($self->getfield($_)) && $self->getfield($_) ne "", - fields($table) - ; - - my($sth); - my($statement)="INSERT INTO $table ( ". - join(', ',@fields ). - ") VALUES (". - join(', ',map(_quote($self->getfield($_),$table,$_), @fields)). - ")" - ; - $sth = $dbh->prepare($statement) or return $dbh->errstr; - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - - $sth->execute or return $sth->errstr; - - ''; -} - -=item del - -Delete this record from the database. If there is an error, returns the error, -otherwise returns false. - -=cut - -sub del { - my($self) = @_; - my($dbh)=dbh; - my($table)=$self->table; - - my($sth); - my($statement)="DELETE FROM $table WHERE ". join(' AND ', - map { - $self->getfield($_) eq '' - ? "$_ IS NULL" - : "$_ = ". _quote($self->getfield($_),$table,$_) - } ( $dbdef->table($table)->primary_key ) - ? ($dbdef->table($table)->primary_key) - : fields($table) - ); - $sth = $dbh->prepare($statement) or return $dbh->errstr; - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - - my($rc); - $rc=$sth->execute or return $sth->errstr; - #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0"; - - undef $self; #no need to keep object! - - ''; -} - -=item rep OLD_RECORD - -Replace the OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -=cut - -sub rep { - my($new,$old)=@_; - my($dbh)=dbh; - my($table)=$old->table; - my(@fields)=fields($table); - my(@diff)=grep $new->getfield($_) ne $old->getfield($_), @fields; - - if ( scalar(@diff) == 0 ) { - carp "Records identical"; - return ''; - } - - return "Records not in same table!" unless $new->table eq $table; - - my($sth); - my($statement)="UPDATE $table SET ". join(', ', - map { - "$_ = ". _quote($new->getfield($_),$table,$_) - } @diff - ). ' WHERE '. - join(' AND ', - map { - $old->getfield($_) eq '' - ? "$_ IS NULL" - : "$_ = ". _quote($old->getfield($_),$table,$_) -# } @fields -# } ( primary_key($table) ? (primary_key($table)) : @fields ) - } ( $dbdef->table($table)->primary_key - ? ($dbdef->table($table)->primary_key) - : @fields - ) - ) - ; - #warn $statement; - $sth = $dbh->prepare($statement) or return $dbh->errstr; - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - - my($rc); - $rc=$sth->execute or return $sth->errstr; - #not portable #return "Record not found (or records identical)." if $rc eq "0E0"; - - ''; - -} - -=item unique COLUMN - -Replaces COLUMN in record with a unique number. Called by the B<add> method -on primary keys and single-field unique columns (see L<FS::dbdef_table>). -Returns the new value. - -=cut - -sub unique { - my($self,$field) = @_; - my($table)=$self->table; - - croak("&FS::UID::checkruid failed") unless &checkruid; - - croak "Unique called on field $field, but it is ", - $self->getfield($field), - ", not null!" - if $self->getfield($field); - - #warn "table $table is tainted" if is_tainted($table); - #warn "field $field is tainted" if is_tainted($field); - - &swapuid; - my($counter) = new File::CounterFile "$table.$field",0; -# hack for web demo -# getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!"; -# my($user)=$1; -# my($counter) = new File::CounterFile "$user/$table.$field",0; -# endhack - - my($index)=$counter->inc; - $index=$counter->inc - while qsearchs($table,{$field=>$index}); #just in case - &swapuid; - - $index =~ /^(\d*)$/; - $index=$1; - - $self->setfield($field,$index); - -} - -=item ut_float COLUMN - -Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May not be -null. If there is an error, returns the error, otherwise returns false. - -=cut - -sub ut_float { - my($self,$field)=@_ ; - ($self->getfield($field) =~ /^(\d+\.\d+)$/ || - $self->getfield($field) =~ /^(\d+)$/ || - $self->getfield($field) =~ /^(\d+\.\d+e\d+)$/ || - $self->getfield($field) =~ /^(\d+e\d+)$/) - or return "Illegal or empty (float) $field!"; - $self->setfield($field,$1); - ''; -} - -=item ut_number COLUMN - -Check/untaint simple numeric data (whole numbers). May not be null. If there -is an error, returns the error, otherwise returns false. - -=cut - -sub ut_number { - my($self,$field)=@_; - $self->getfield($field) =~ /^(\d+)$/ - or return "Illegal or empty (numeric) $field!"; - $self->setfield($field,$1); - ''; -} - -=item ut_numbern COLUMN - -Check/untaint simple numeric data (whole numbers). May be null. If there is -an error, returns the error, otherwise returns false. - -=cut - -sub ut_numbern { - my($self,$field)=@_; - $self->getfield($field) =~ /^(\d*)$/ - or return "Illegal (numeric) $field!"; - $self->setfield($field,$1); - ''; -} - -=item ut_money COLUMN - -Check/untaint monetary numbers. May be negative. Set to 0 if null. If there -is an error, returns the error, otherwise returns false. - -=cut - -sub ut_money { - my($self,$field)=@_; - $self->getfield($field) =~ /^(\-)? ?(\d*)(\.\d{2})?$/ - or return "Illegal (money) $field!"; - $self->setfield($field,"$1$2$3" || 0); - ''; -} - -=item ut_text COLUMN - -Check/untaint text. Alphanumerics, spaces, and the following punctuation -symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / -May not be null. If there is an error, returns the error, otherwise returns -false. - -=cut - -sub ut_text { - my($self,$field)=@_; - $self->getfield($field) =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/]+)$/ - or return "Illegal or empty (text) $field"; - $self->setfield($field,$1); - ''; -} - -=item ut_textn COLUMN - -Check/untaint text. Alphanumerics, spaces, and the following punctuation -symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / -May be null. If there is an error, returns the error, otherwise returns false. - -=cut - -sub ut_textn { - my($self,$field)=@_; - $self->getfield($field) =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/]*)$/ - or return "Illegal (text) $field"; - $self->setfield($field,$1); - ''; -} - -=item ut_alpha COLUMN - -Check/untaint alphanumeric strings (no spaces). May not be null. If there is -an error, returns the error, otherwise returns false. - -=cut - -sub ut_alpha { - my($self,$field)=@_; - $self->getfield($field) =~ /^(\w+)$/ - or return "Illegal or empty (alphanumeric) $field!"; - $self->setfield($field,$1); - ''; -} - -=item ut_alpha COLUMN - -Check/untaint alphanumeric strings (no spaces). May be null. If there is an -error, returns the error, otherwise returns false. - -=cut - -sub ut_alphan { - my($self,$field)=@_; - $self->getfield($field) =~ /^(\w*)$/ - or return "Illegal (alphanumeric) $field!"; - $self->setfield($field,$1); - ''; -} - -=item ut_phonen COLUMN - -Check/untaint phone numbers. May be null. If there is an error, returns -the error, otherwise returns false. - -=cut - -sub ut_phonen { - my($self,$field)=@_; - my $phonen = $self->getfield($field); - if ( $phonen eq '' ) { - $self->setfield($field,''); - } else { - $phonen =~ s/\D//g; - $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/ - or return "Illegal (phone) $field!"; - $phonen = "$1-$2-$3"; - $phonen .= " x$4" if $4; - $self->setfield($field,$phonen); - } - ''; -} - -=item ut_anything COLUMN - -Untaints arbitrary data. Be careful. - -=cut - -sub ut_anything { - my($self,$field)=@_; - $self->getfield($field) =~ /^(.*)$/ or return "Illegal $field!"; - $self->setfield($field,$1); - ''; -} - - -=head1 SUBROUTINES - -=over 4 - -=item reload_dbdef([FILENAME]) - -Load a database definition (see L<FS::dbdef>), optionally from a non-default -filename. This command is executed at startup unless -I<$FS::Record::setup_hack> is true. Returns a FS::dbdef object. - -=cut - -sub reload_dbdef { - my $file = shift || $dbdef_file; - $dbdef = load FS::dbdef ($file); -} - -=item dbdef - -Returns the current database definition. See L<FS::dbdef>. - -=cut - -sub dbdef { $dbdef; } - -=item _quote VALUE, TABLE, COLUMN - -This is an internal function used to construct SQL statements. It returns -VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column -type (see L<dbdef_column>) does not end in `char' or `binary'. - -=cut - -sub _quote { - my($value,$table,$field)=@_; - my($dbh)=dbh; - if ( $value =~ /^\d+(\.\d+)?$/ && -# ! ( datatype($table,$field) =~ /^char/ ) - ! ( $dbdef->table($table)->column($field)->type =~ /(char|binary)$/i ) - ) { - $value; - } else { - $dbh->quote($value); - } -} - -=item hfields TABLE - -This is depriciated. Don't use it. - -It returns a hash-type list with the fields of this record's table set true. - -=cut - -sub hfields { - carp "hfields is depriciated"; - my($table)=@_; - my(%hash); - foreach (fields($table)) { - $hash{$_}=1; - } - \%hash; -} - -=item fields TABLE - -This returns a list of the columns in this record's table -(See L<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 { -# "$_: ". $self->getfield($_). "|" -# } (fields($self->table)) ); -#} - -#sub DESTROY { -# my $self = shift; -# #use Carp qw(cluck); -# #cluck "DESTROYING $self"; -# warn "DESTROYING $self"; -#} - -#sub is_tainted { -# return ! eval { join('',@_), kill 0; 1; }; -# } - -=back - -=head1 BUGS - -This module should probably be renamed, since much of the functionality is -of general use. It is not completely unlike Adapter::DBI (see below). - -Exported qsearch and qsearchs should be depriciated in favor of method calls -(against an FS::Record object like the old search and searchs that qsearch -and qsearchs were on top of.) - -The whole fields / hfields mess should be removed. - -The various WHERE clauses should be subroutined. - -table string should be depriciated in favor of FS::dbdef_table. - -No doubt we could benefit from a Tied hash. Documenting how exists / defined -true maps to the database (and WHERE clauses) would also help. - -The ut_ methods should ask the dbdef for a default length. - -ut_sqltype (like ut_varchar) should all be defined - -A fallback check method should be provided with uses the dbdef. - -The ut_money method assumes money has two decimal digits. - -The Pg money kludge in the new method only strips `$'. - -The ut_phonen method assumes US-style phone numbers. - -The _quote function should probably use ut_float instead of a regex. - -All the subroutines probably should be methods, here or elsewhere. - -=head1 SEE ALSO - -L<FS::dbdef>, L<FS::UID>, L<DBI> - -Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan. - -=head1 HISTORY - -ivan@voicenet.com 97-jun-2 - 9, 19, 25, 27, 30 - -DBI version -ivan@sisd.com 97-nov-8 - 12 - -cleaned up, added autoloaded $self->any_field calls, moved DBI login stuff -to FS::UID -ivan@sisd.com 97-nov-21-23 - -since AUTO_INCREMENT is MySQL specific, use my own unique number generator -(again) -ivan@sisd.com 97-dec-4 - -untaint $user in unique (web demo hack...bah) -make unique skip multiple-field unique's from dbdef -ivan@sisd.com 97-dec-11 - -merge with FS::Search, which after all was just alternate constructors for -FS::Record objects. Makes lots of things cleaner. :) -ivan@sisd.com 97-dec-13 - -use FS::dbdef::primary key in replace searches, hopefully for all practical -purposes the string/number problem in SQL statements should be gone? -(SQL bites) -ivan@sisd.com 98-jan-20 - -Put all SQL statments in $statment before we $sth=$dbh->prepare( them, -for debugging reasons (warn $statement) ivan@sisd.com 98-feb-19 - -(sigh)... use dbdef type (char, etc.) instead of a regex to decide -what to quote in _quote (more sillines...) SQL bites. -ivan@sisd.com 98-feb-20 - -more friendly error messages ivan@sisd.com 98-mar-13 - -Added import of datasrc from FS::UID to allow Pg6.3 to work -Added code to right-trim strings read from Pg6.3 databases -Modified 'add' to only insert fields that actually have data -Added ut_float to handle floating point numbers (for sales tax). -Pg6.3 does not have a "SHOW FIELDS" statement, so I faked it 8). - bmccane@maxbaud.net 98-apr-3 - -commented out Pg wrapper around `` Modified 'add' to only insert fields that -actually have data '' ivan@sisd.com 98-apr-16 - -dbdef usage changes ivan@sisd.com 98-jun-1 - -sub fields now asks dbdef, not database ivan@sisd.com 98-jun-2 - -added debugging method ->_dump ivan@sisd.com 98-jun-16 - -use FS::dbdef::primary key in delete searches as well as replace -searches (SQL still bites) ivan@sisd.com 98-jun-22 - -sub dbdef_table ivan@sisd.com 98-jun-28 - -removed Pg wrapper around `` Modified 'add' to only insert fields that -actually have data '' ivan@sisd.com 98-jul-14 - -sub fields croaks on errors ivan@sisd.com 98-jul-17 - -$rc eq '0E0' doesn't mean we couldn't delete for all rdbmss -ivan@sisd.com 98-jul-18 - -commented out code to right-trim strings read from Pg6.3 databases; -ChopBlanks is in UID.pm ivan@sisd.com 98-aug-16 - -added code (with Pg wrapper) to deal with Pg money fields -ivan@sisd.com 98-aug-18 - -added pod documentation ivan@sisd.com 98-sep-6 - -ut_phonen got ''; at the end ivan@sisd.com 98-sep-27 - -=cut - -1; - diff --git a/site_perl/SSH.pm b/site_perl/SSH.pm deleted file mode 100644 index d5a0df6..0000000 --- a/site_perl/SSH.pm +++ /dev/null @@ -1,157 +0,0 @@ -package FS::SSH; - -use strict; -use vars qw(@ISA @EXPORT_OK $ssh $scp); -use Exporter; -use IPC::Open2; -use IPC::Open3; - -@ISA = qw(Exporter); -@EXPORT_OK = qw(ssh scp issh iscp sshopen2 sshopen3); - -$ssh="ssh"; -$scp="scp"; - -=head1 NAME - -FS::SSH - Subroutines to call ssh and scp - -=head1 SYNOPSIS - - use FS::SSH qw(ssh scp issh iscp sshopen2 sshopen3); - - ssh($host, $command); - - issh($host, $command); - - scp($source, $destination); - - iscp($source, $destination); - - sshopen2($host, $reader, $writer, $command); - - sshopen3($host, $reader, $writer, $error, $command); - -=head1 DESCRIPTION - - Simple wrappers around ssh and scp commands. - -=head1 SUBROUTINES - -=over 4 - -=item ssh HOST, COMMAND - -Calls ssh in batch mode. - -=cut - -sub ssh { - my($host,$command)=@_; - my(@cmd)=($ssh, "-o", "BatchMode yes", $host, $command); -# print join(' ',@cmd),"\n"; -#0; - system(@cmd); -} - -=item issh HOST, COMMAND - -Prints the ssh command to be executed, waits for the user to confirm, and -(optionally) executes the command. - -=cut - -sub issh { - my($host,$command)=@_; - my(@cmd)=($ssh, $host, $command); - print join(' ',@cmd),"\n"; - if ( &_yesno ) { - ###print join(' ',@cmd),"\n"; - system(@cmd); - } -} - -=item scp SOURCE, DESTINATION - -Calls scp in batch mode. - -=cut - -sub scp { - my($src,$dest)=@_; - my(@cmd)=($scp,"-Bprq",$src,$dest); -# print join(' ',@cmd),"\n"; -#0; - system(@cmd); -} - -=item iscp SOURCE, DESTINATION - -Prints the scp command to be executed, waits for the user to confirm, and -(optionally) executes the command. - -=cut - -sub iscp { - my($src,$dest)=@_; - my(@cmd)=($scp,"-pr",$src,$dest); - print join(' ',@cmd),"\n"; - if ( &_yesno ) { - ###print join(' ',@cmd),"\n"; - system(@cmd); - } -} - -=item sshopen2 HOST, READER, WRITER, COMMAND - -Connects the supplied filehandles to the ssh process (in batch mode). - -=cut - -sub sshopen2 { - my($host,$reader,$writer,$command)=@_; - open2($reader,$writer,$ssh,'-o','Batchmode yes',$host,$command); -} - -=item sshopen3 HOST, WRITER, READER, ERROR, COMMAND - -Connects the supplied filehandles to the ssh process (in batch mode). - -=cut - -sub sshopen3 { - my($host,$writer,$reader,$error,$command)=@_; - open3($writer,$reader,$error,$ssh,'-o','Batchmode yes',$host,$command); -} - -sub _yesno { - print "Proceed [y/N]:"; - my($x)=scalar(<STDIN>); - $x =~ /^y/i; -} - -=head1 BUGS - -Not OO. - -scp stuff should transparantly use rsync-over-ssh instead. - -=head1 SEE ALSO - -L<ssh>, L<scp>, L<IPC::Open2>, L<IPC::Open3> - -=head1 HISTORY - -ivan@voicenet.com 97-jul-17 - -added sshopen2 and sshopen3 ivan@sisd.com 98-mar-9 - -added iscp ivan@sisd.com 98-jul-25 -now iscp asks y/n, issh and took out path ivan@sisd.com 98-jul-30 - -pod ivan@sisd.com 98-sep-21 - -=cut - -1; - diff --git a/site_perl/UID.pm b/site_perl/UID.pm deleted file mode 100644 index 16f03a0..0000000 --- a/site_perl/UID.pm +++ /dev/null @@ -1,209 +0,0 @@ -package FS::UID; - -use strict; -use vars qw( - @ISA @EXPORT_OK $cgi $dbh $freeside_uid $conf $datasrc $db_user $db_pass -); -use Exporter; -use Carp; -use DBI; -use FS::Conf; - -@ISA = qw(Exporter); -@EXPORT_OK = qw(checkeuid checkruid swapuid cgisuidsetup - adminsuidsetup getotaker dbh datasrc); - -$freeside_uid = scalar(getpwnam('freeside')); - -my $conf = new FS::Conf; -($datasrc, $db_user, $db_pass) = $conf->config('secrets') - or die "Can't get secrets: $!"; - -=head1 NAME - -FS::UID - Subroutines for database login and assorted other stuff - -=head1 SYNOPSIS - - use FS::UID qw(adminsuidsetup cgisuidsetup dbh datasrc getotaker - checkeuid checkruid swapuid); - - adminsuidsetup; - - $cgi = new CGI::Base; - $cgi->get; - $dbh = cgisuidsetup($cgi); - - $dbh = dbh; - - $datasrc = datasrc; - -=head1 DESCRIPTION - -Provides a hodgepodge of subroutines. - -=head1 SUBROUTINES - -=over 4 - -=item adminsuidsetup - -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. -Returns the DBI database handle (usually you don't need this). - -=cut - -sub adminsuidsetup { - - $ENV{'PATH'} ='/usr/local/bin:/usr/bin:/usr/ucb:/bin'; - $ENV{'SHELL'} = '/bin/sh'; - $ENV{'IFS'} = " \t\n"; - $ENV{'CDPATH'} = ''; - $ENV{'ENV'} = ''; - $ENV{'BASH_ENV'} = ''; - - croak "Not running uid freeside!" unless checkeuid(); - $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";; - - swapuid(); #go to non-privledged user if running setuid freeside - - $dbh; -} -=item cgisuidsetup CGI::Base_OBJECT - -Stores the CGI::Base_OBJECT for later use. -Runs adminsuidsetup. - -=cut - -sub cgisuidsetup { - $cgi=$_[0]; - adminsuidsetup; -} - -=item dbh - -Returns the DBI database handle. - -=cut - -sub dbh { - $dbh; -} - -=item datasrc - -Returns the DBI data source. - -=cut - -sub datasrc { - $datasrc; -} - -#hack for web demo -#sub setdbh { -# $dbh=$_[0]; -#} - -sub suidsetup { - croak "suidsetup depriciated"; -} - -=item getotaker - -Returns the current Freeside user. Currently that means the CGI REMOTE_USER, -or 'freeside'. - -=cut - -sub getotaker { - if ($cgi && defined $cgi->var('REMOTE_USER')) { - return $cgi->var('REMOTE_USER'); #for now - } else { - 'freeside'; - } -} - -=item checkeuid - -Returns true if effective UID is that of the freeside user. - -=cut - -sub checkeuid { - ( $> == $freeside_uid ); -} - -=item checkruid - -Returns true if the real UID is that of the freeside user. - -=cut - -sub checkruid { - ( $< == $freeside_uid ); -} - -=item swapuid - -Swaps real and effective UIDs. - -=cut - -sub swapuid { - ($<,$>) = ($>,$<); -} - -=back - -=head1 BUGS - -Not OO. - -No capabilities yet. When mod_perl and Authen::DBI are implemented, -cgisuidsetup will go away as well. - -=head1 SEE ALSO - -L<FS::Record>, L<CGI::Base>, L<DBI> - -=head1 HISTORY - -ivan@voicenet.com 97-jun-4 - 9 - -untaint otaker ivan@voicenet.com 97-jul-7 - -generalize and auto-get uid (getotaker still needs to be db'ed) -ivan@sisd.com 97-nov-10 - -&cgisuidsetup logs into database. other cleaning. -ivan@sisd.com 97-nov-22,23 - -&adminsuidsetup logs into database with otaker='freeside' (for -automated tasks like billing) -ivan@sisd.com 97-dec-13 - -added sub datasrc for fs-setup ivan@sisd.com 98-feb-21 - -datasrc, user and pass now come from conf/secrets ivan@sisd.com 98-jun-28 - -added ChopBlanks to DBI call (see man DBI) ivan@sisd.com 98-aug-16 - -pod, use FS::Conf, implemented cgisuidsetup as adminsuidsetup, -inlined suidsetup -ivan@sisd.com 98-sep-12 - -=cut - -1; - diff --git a/site_perl/agent.pm b/site_perl/agent.pm deleted file mode 100644 index 7fc370e..0000000 --- a/site_perl/agent.pm +++ /dev/null @@ -1,166 +0,0 @@ -package FS::agent; - -use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(fields qsearch qsearchs); - -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); - -=head1 NAME - -FS::agent - Object methods for agent records - -=head1 SYNOPSIS - - use FS::agent; - - $record = create FS::agent \%hash; - $record = create FS::agent { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::agent object represents an agent. Every customer has an agent. Agents -can be used to track things like resellers or salespeople. FS::agent inherits -from FS::Record. The following fields are currently supported: - -=over 4 - -=item agemtnum - primary key (assigned automatically for new agents) - -=item agent - Text name of this agent - -=item typenum - Agent type. See L<FS::agent_type> - -=item prog - For future use. - -=item freq - For future use. - -=back - -=head1 METHODS - -=over 4 - -=item create 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); -} - -=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 -deleted. If there is an error, returns the error, otherwise returns false. - -=cut - -sub delete { - my($self)=@_; - return "Can't delete an agent with customers!" - if qsearch('cust_main',{'agentnum' => $self->agentnum}); - $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 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, -returns the error, otherwise returns false. Called by the insert and replace -methods. - -=cut - -sub check { - my($self)=@_; - return "Not a agent record!" unless $self->table eq "agent"; - - 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') - ; - return $error if $error; - - return "Unknown typenum!" - unless qsearchs('agent_type',{'typenum'=> $self->getfield('typenum') }); - - ''; - -} - -=back - -=head1 BUGS - -It doesn't properly override FS::Record yet. - -=head1 SEE ALSO - -L<FS::Record>, L<FS::agent_type>, L<FS::cust_main>, schema.html from the base -documentation. - -=head1 HISTORY - -Class dealing with agent (resellers) - -ivan@sisd.com 97-nov-13, 97-dec-10 - -pod, added check in ->delete ivan@sisd.com 98-sep-22 - -=cut - -1; - diff --git a/site_perl/agent_type.pm b/site_perl/agent_type.pm deleted file mode 100644 index 002c36f..0000000 --- a/site_perl/agent_type.pm +++ /dev/null @@ -1,161 +0,0 @@ -package FS::agent_type; - -use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(qsearch fields); - -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); - -=head1 NAME - -FS::agent_type - Object methods for agent_type records - -=head1 SYNOPSIS - - use FS::agent_type; - - $record = create FS::agent_type \%hash; - $record = create FS::agent_type { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::agent_type object represents an agent type. Every agent (see -L<FS::agent>) has an agent type. Agent types define which packages (see -L<FS::part_pkg>) may be purchased by customers (see L<FS::cust_main>), via -FS::type_pkgs records (see L<FS::type_pkgs>). FS::agent_type inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item typenum - primary key (assigned automatically for new agent types) - -=item atype - Text name of this agent type - -=back - -=head1 METHODS - -=over 4 - -=item create 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); - -} - -=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 -can be deleted. If there is an error, returns the error, otherwise returns -false. - -=cut - -sub delete { - my($self)=@_; - return "Can't delete an agent_type with agents!" - if qsearch('agent',{'typenum' => $self->typenum}); - $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 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 -error, returns the error, otherwise returns false. Called by the insert and -replace methods. - -=cut - -sub check { - my($self)=@_; - return "Not a agent_type record!" unless $self->table eq "agent_type"; - - $self->ut_numbern('typenum') - or $self->ut_text('atype'); - -} - -=back - -=head1 BUGS - -It doesn't properly override FS::Record yet. - -=head1 SEE ALSO - -L<FS::Record>, L<FS::agent>, L<FS::type_pkgs>, L<FS::cust_main>, -L<FS::part_pkg>, schema.html from the base documentation. - -=head1 HISTORY - -Class for the different sets of allowable packages you can assign to an -agent. - -ivan@sisd.com 97-nov-13 - -ut_ FS::Record methods -ivan@sisd.com 97-dec-10 - -Changed 'type' to 'atype' because Pg6.3 reserves the type word - bmccane@maxbaud.net 98-apr-3 - -pod, added check in delete ivan@sisd.com 98-sep-21 - -=cut - -1; - diff --git a/site_perl/cust_bill.pm b/site_perl/cust_bill.pm deleted file mode 100644 index 0023451..0000000 --- a/site_perl/cust_bill.pm +++ /dev/null @@ -1,495 +0,0 @@ -package FS::cust_bill; - -use strict; -use vars qw(@ISA $conf $add1 $add2 $add3 $add4); -use Exporter; -use Date::Format; -use FS::Record qw(fields qsearch qsearchs); - -@ISA = qw(FS::Record Exporter); - -$conf = new FS::Conf; - -($add1,$add2,$add3,$add4) = $conf->config('address'); - -=head1 NAME - -FS::cust_bill - Object methods for cust_bill records - -=head1 SYNOPSIS - - use FS::cust_bill; - - $record = create FS::cust_bill \%hash; - $record = create FS::cust_bill { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - - ( $total_previous_balance, @previous_cust_bill ) = $record->previous; - - @cust_bill_pkg_objects = $cust_bill->cust_bill_pkg; - - ( $total_previous_credits, @previous_cust_credit ) = $record->cust_credit; - - @cust_pay_objects = $cust_bill->cust_pay; - - @lines = $cust_bill->print_text; - @lines = $cust_bill->print_text $time; - -=head1 DESCRIPTION - -An FS::cust_bill object represents an invoice. FS::cust_bill inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item invnum - primary key (assigned automatically for new invoices) - -=item custnum - customer (see L<FS::cust_main>) - -=item _date - specified as a UNIX timestamp; see L<perlfunc/"time">. Also see -L<Time::Local> and L<Date::Parse> for conversion functions. - -=item charged - amount of this invoice - -=item owed - amount still outstanding on this invoice, which is charged minus -all payments (see L<FS::cust_pay>). - -=item printed - how many times this invoice has been printed automatically -(see L<FS::cust_main/"collect">). - -=back - -=head1 METHODS - -=over 4 - -=item create HASHREF - -Creates a new invoice. To add the invoice to the database, see L<"insert">. -Invoices are normally created by calling the bill method of a customer object -(see L<FS::cust_main>). - -=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); -} - -=item insert - -Adds this invoice to the database ("Posts" the invoice). If there is an error, -returns the error, otherwise returns false. - -When adding new invoices, owed must be charged (or null, in which case it is -automatically set to charged). - -=cut - -sub insert { - my($self)=@_; - - $self->setfield('owed',$self->charged) if $self->owed eq ''; - return "owed != charged!" - unless $self->owed == $self->charged; - - $self->check or - $self->add; -} - -=item delete - -Currently unimplemented. I don't remove invoices because there would then be -no record you ever posted this invoice (which is bad, no?) - -=cut - -sub delete { - return "Can't remove invoice!" - #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. - -Only owed and printed may be changed. Owed is normally updated by creating and -inserting a payment (see L<FS::cust_pay>). Printed is normally updated by -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); -} - -=item check - -Checks all fields to make sure this is a valid invoice. If there is an error, -returns the error, otherwise returns false. Called by the insert and replace -methods. - -=cut - -sub check { - my($self)=@_; - 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; - - $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; - - $recref->{owed} =~ /^(\-?\d+(\.\d\d)?)$/ or return "Illegal owed"; - $recref->{owed} = $1; - - $recref->{printed} =~ /^(\d*)$/ or return "Illegal printed"; - $recref->{printed} = $1 || '0'; - - ''; #no error -} - -=item previous - -Returns a list consisting of the total previous balance for this customer, -followed by the previous outstanding invoices (as FS::cust_bill objects also). - -=cut - -sub previous { - my($self)=@_; - my($total)=0; - my(@cust_bill) = sort { $a->_date <=> $b->_date } - grep { $_->owed != 0 && $_->_date < $self->_date } - qsearch('cust_bill',{ 'custnum' => $self->custnum } ) - ; - foreach (@cust_bill) { $total += $_->owed; } - $total, @cust_bill; -} - -=item cust_bill_pkg - -Returns the line items (see L<FS::cust_bill_pkg>) for this invoice. - -=cut - -sub cust_bill_pkg { - my($self)=@_; - qsearch( 'cust_bill_pkg', { 'invnum' => $self->invnum } ); -} - -=item cust_credit - -Returns a list consisting of the total previous credited (see -L<FS::cust_credit>) for this customer, followed by the previous outstanding -credits (FS::cust_credit objects). - -=cut - -sub cust_credit { - my($self)=@_; - my($total)=0; - my(@cust_credit) = sort { $a->_date <=> $b->date } - grep { $_->credited != 0 && $_->_date < $self->_date } - qsearch('cust_credit', { 'custnum' => $self->custnum } ) - ; - foreach (@cust_credit) { $total += $_->credited; } - $total, @cust_credit; -} - -=item cust_pay - -Returns all payments (see L<FS::cust_pay>) for this invoice. - -=cut - -sub cust_pay { - my($self)=@_; - sort { $a->_date <=> $b->date } - qsearch( 'cust_pay', { 'invnum' => $self->invnum } ) - ; -} - -=item print_text [TIME]; - -Returns an ASCII invoice, as a list of lines. - -TIME an optional value used to control the printing of overdue messages. The -default is now. It isn't the date of the invoice; that's the `_date' field. -It is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see -L<Time::Local> and L<Date::Parse> for conversion functions. - -=cut - -sub print_text { - - my($self,$today)=@_; - $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($pr_total,@pr_cust_bill) = $self->previous; #previous balance - my($cr_total,@cr_cust_credit) = $self->cust_credit; #credits - my($balance_due) = $self->owed + $pr_total - $cr_total; - - #overdue? - my($overdue) = ( - $balance_due > 0 - && $today > $self->_date - && $self->printed > 1 - ); - - #printing bits here - - 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; - - - - - - - -END - - #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 ) { - - 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; - - push @buf, ( "$pkg Setup",'$' . sprintf("%10.2f",$_->setup) ) - if $_->setup != 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,('','-----------'); - 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_pages)=int(scalar(@buf)/30); #15 lines, 2 values per line - $tot_pages++ if scalar(@buf) % 30; - - while (@buf) { - $description=shift(@buf); - $amount=shift(@buf); - write; - } - ($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 = - @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<< - $description,$amount -. - - } #endchild - -} - -=back - -=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 ($=). - -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>, -L<FS::cust_credit>, schema.html from the base documentation. - -=head1 HISTORY - -ivan@voicenet.com 97-jul-1 - -small fix for new API ivan@sisd.com 98-mar-14 - -charges can be negative ivan@sisd.com 98-jul-13 - -pod, ingegrate with FS::Invoice ivan@sisd.com 98-sep-20 - -=cut - -1; - diff --git a/site_perl/cust_bill_pkg.pm b/site_perl/cust_bill_pkg.pm deleted file mode 100644 index e41d7c1..0000000 --- a/site_perl/cust_bill_pkg.pm +++ /dev/null @@ -1,177 +0,0 @@ -package FS::cust_bill_pkg; - -use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(fields qsearchs); - -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); - -=head1 NAME - -FS::cust_bill_pkg - Object methods for cust_bill_pkg records - -=head1 SYNOPSIS - - use FS::cust_bill_pkg; - - $record = create FS::cust_bill_pkg \%hash; - $record = create FS::cust_bill_pkg { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::cust_bill_pkg object represents an invoice line item. -FS::cust_bill_pkg inherits from FS::Record. The following fields are currently -supported: - -=over 4 - -=item invnum - invoice (see L<FS::cust_bill>) - -=item pkgnum - package (see L<FS::cust_pkg>) - -=item setup - setup fee - -=item recur - recurring fee - -=item sdate - starting date of recurring fee - -=item edate - ending date of recurring fee - -=back - -sdate and edate are specified as UNIX timestamps; see L<perlfunc/"time">. Also -see L<Time::Local> and L<Date::Parse> for conversion functions. - -=head1 METHODS - -=over 4 - -=item create HASHREF - -Creates a new line item. To add the line item to the database, see -L<"insert">. Line items are normally created by calling the bill method of a -customer object (see L<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); - -} - -=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 -no record the items ever existed (which is bad, no?) - -=cut - -sub delete { - return "Can't delete cust_bill_pkg records!"; - #my($self)=@_; - #$self->del; -} - -=item replace OLD_RECORD - -Currently unimplemented. This would be even more of an accounting nightmare -than deleteing the items. Just don't do it. - -=cut - -sub replace { - return "Can't modify cust_bill_pkg records!"; - #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 - -Checks all fields to make sure this is a valid line item. If there is an -error, returns the error, otherwise returns false. Called by the insert -method. - -=cut - -sub check { - my($self)=@_; - return "Not a cust_bill_pkg record!" unless $self->table eq "cust_bill_pkg"; - - 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') - ; - return $error if $error; - - if ( $self->pkgnum != 0 ) { #allow unchecked pkgnum 0 for tax! (add to part_pkg?) - return "Unknown pkgnum ".$self->pkgnum - unless qsearchs('cust_pkg',{'pkgnum'=> $self->pkgnum }); - } - - return "Unknown invnum" - unless qsearchs('cust_bill',{'invnum'=> $self->invnum }); - - ''; #no error -} - -=back - -=head1 BUGS - -It doesn't properly override FS::Record yet. - -=head1 SEE ALSO - -L<FS::Record>, L<FS::cust_bill>, L<FS::cust_pkg>, L<FS::cust_main>, schema.html -from the base documentation. - -=head1 HISTORY - -ivan@sisd.com 98-mar-13 - -pod ivan@sisd.com 98-sep-21 - -=cut - -1; - diff --git a/site_perl/cust_credit.pm b/site_perl/cust_credit.pm deleted file mode 100644 index b1a5e16..0000000 --- a/site_perl/cust_credit.pm +++ /dev/null @@ -1,199 +0,0 @@ -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); - -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); - -=head1 NAME - -FS::cust_credit - Object methods for cust_credit records - -=head1 SYNOPSIS - - use FS::cust_credit; - - $record = create FS::cust_credit \%hash; - $record = create FS::cust_credit { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::cust_credit object represents a credit. FS::cust_credit inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item crednum - primary key (assigned automatically for new credits) - -=item custnum - customer (see L<FS::cust_main>) - -=item amount - amount of the credit - -=item credited - how much of this credit that is still outstanding, which is -amount minus all refunds (see L<FS::cust_refund>). - -=item _date - specified as a UNIX timestamp; see L<perlfunc/"time">. Also see -L<Time::Local> and L<Date::Parse> for conversion functions. - -=item otaker - order taker (assigned automatically, see L<FS::UID>) - -=item reason - text - -=back - -=head1 METHODS - -=over 4 - -=item create 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); -} - -=item insert - -Adds this credit to the database ("Posts" the credit). If there is an error, -returns the error, otherwise returns false. - -When adding new invoices, credited must be amount (or null, in which case it is -automatically set to amount). - -=cut - -sub insert { - my($self)=@_; - - $self->setfield('credited',$self->amount) if $self->credited eq ''; - return "credited != amount!" - unless $self->credited == $self->amount; - - $self->check or - $self->add; -} - -=item delete - -Currently unimplemented. - -=cut - -sub delete { - return "Can't remove credit!" - #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. - -Only credited may be changed. Credited is normally updated by creating and -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'); - return "(New) credited can't be > (new) amount!" - if $new->getfield('credited') > $new->getfield('amount'); - - $new->check or - $new->rep($old); -} - -=item check - -Checks all fields to make sure this is a valid credit. If there is an error, -returns the error, otherwise returns false. Called by the insert and replace -methods. - -=cut - -sub check { - my($self)=@_; - 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; - - $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; - - $recref->{credited} =~ /^(\-?\d+(\.\d\d)?)$/ or return "Illegal credited"; - $recref->{credited} = $1; - - #$recref->{otaker} =~ /^(\w+)$/ or return "Illegal otaker"; - #$recref->{otaker} = $1; - $self->otaker(getotaker); - - $self->ut_textn('reason'); - -} - -=back - -=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 -documentation. - -=head1 HISTORY - -ivan@sisd.com 98-mar-17 - -pod, otaker from FS::UID ivan@sisd.com 98-sep-21 - -=cut - -1; - diff --git a/site_perl/cust_main.pm b/site_perl/cust_main.pm deleted file mode 100644 index ec28273..0000000 --- a/site_perl/cust_main.pm +++ /dev/null @@ -1,868 +0,0 @@ -#this is so kludgy i'd be embarassed if it wasn't cybercash's fault -package main; -use vars qw($paymentserversecret $paymentserverport $paymentserverhost); - -package FS::cust_main; - -use strict; -use vars qw(@ISA @EXPORT_OK $conf $lpr $processor $xaction $E_NoErr); -use Safe; -use Exporter; -use Carp; -use Time::Local; -use Date::Format; -use Date::Manip; -use Business::CreditCard; -use FS::UID qw(getotaker); -use FS::Record qw(fields hfields 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" - } - my($errmsg) = &CCMckErrno3_2::MCKGetErrorMessage($status); - die "CCMckLib3_2::InitConfig fatal error: $errmsg\n"; - } - $processor='cybercash3.2'; -} elsif ( $conf->exists('cybercash2') ) { - require CCLib; - #qw(sendmserver); - ( $main::paymentserverhost, - $main::paymentserverport, - $main::paymentserversecret, - $xaction, - ) = $conf->config('cybercash2'); - $processor='cybercash2'; -} - -=head1 NAME - -FS::cust_main - Object methods for cust_main records - -=head1 SYNOPSIS - - use FS::cust_main; - - $record = create FS::cust_main \%hash; - $record = create FS::cust_main { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - - @cust_pkg = $record->all_pkgs; - - @cust_pkg = $record->ncancelled_pkgs; - - $error = $record->bill; - $error = $record->bill %options; - $error = $record->bill 'time' => $time; - - $error = $record->collect; - $error = $record->collect %options; - $error = $record->collect 'invoice_time' => $time, - 'batch_card' => 'yes', - 'report_badcard' => 'yes', - ; - -=head1 DESCRIPTION - -An FS::cust_main object represents a customer. FS::cust_main inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item custnum - primary key (assigned automatically for new customers) - -=item agentnum - agent (see L<FS::agent>) - -=item refnum - referral (see L<FS::part_referral>) - -=item first - name - -=item last - name - -=item ss - social security number (optional) - -=item company - (optional) - -=item address1 - -=item address2 - (optional) - -=item city - -=item county - (optional, see L<FS::cust_main_county>) - -=item state - (see L<FS::cust_main_county>) - -=item zip - -=item country - (see L<FS::cust_main_county>) - -=item daytime - phone (optional) - -=item night - phone (optional) - -=item payby - `CARD' (credit cards), `BILL' (billing), or `COMP' (free) - -=item payinfo - card number, P.O.#, or comp issuer (4-8 lowercase alphanumerics; think username) - -=item paydate - expiration date, mm/yyyy, m/yyyy, mm/yy or m/yy - -=item payname - name on card or billing name - -=item tax - tax exempt, empty or `Y' - -=item otaker - order taker (assigned automatically, see L<FS::UID>) - -=back - -=head1 METHODS - -=over 4 - -=item create HASHREF - -Creates a new customer. To add the customer to the database, see L<"insert">. - -Note that this stores the hash reference, not a distinct copy of the hash it -points to. You can ask the object for a copy with the I<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); -} - -=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 -packages (cust_pkg)? - -I don't remove the customer record in the database because there would then -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 - -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 -an error, returns the error, otherwise returns false. Called by the insert -and repalce methods. - -=cut - -sub check { - my($self)=@_; - - return "Not a cust_main record!" unless $self->table eq "cust_main"; - - my $error = - $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_phonen('daytime') - || $self->ut_phonen('night') - || $self->ut_phonen('fax') - ; - return $error if $error; - - return "Unknown agent" - unless qsearchs('agent',{'agentnum'=>$self->agentnum}); - - return "Unknown referral" - unless qsearchs('part_referral',{'refnum'=>$self->refnum}); - - $self->getfield('last') =~ /^([\w \,\.\-\']+)$/ or return "Illegal last name"; - $self->setfield('last',$1); - - $self->first =~ /^([\w \,\.\-\']+)$/ or return "Illegal first name"; - $self->first($1); - - if ( $self->ss eq '' ) { - $self->ss(''); - } else { - my $ss = $self->ss; - $ss =~ s/\D//g; - $ss =~ /^(\d{3})(\d{2})(\d{4})$/ - or return "Illegal social security number"; - $self->ss("$1-$2-$3"); - } - - return "Unknown state/county/country" - unless qsearchs('cust_main_county',{ - 'state' => $self->state, - 'county' => $self->county, - } ); - - #int'l zips? - $self->zip =~ /^(\d{5}(-\d{4})?)$/ or return "Illegal 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($1); - - if ( $self->payby eq 'CARD' ) { - - my $payinfo = $self->payinfo; - $payinfo =~ s/\D//g; - $payinfo =~ /^(\d{13,16})$/ - or return "Illegal credit card number"; - $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/ ); - - } elsif ( $self->payby eq 'BILL' ) { - - $self->payinfo =~ /^([\w \-]*)$/ or return "Illegal P.O. number"; - $self->payinfo($1); - - } elsif ( $self->payby eq 'COMP' ) { - - $self->payinfo =~ /^(\w{2,8})$/ or return "Illegal comp account issuer"; - $self->payinfo($1); - - } - - if ( $self->paydate eq '' ) { - return "Expriation date required" unless $self->payby eq 'BILL'; - $self->paydate(''); - } else { - $self->paydate =~ /^(\d{1,2})[\/\-](\d{2}(\d{2})?)$/ - or return "Illegal expiration date"; - if ( length($2) == 4 ) { - $self->paydate("$2-$1-01"); - } elsif ( $2 > 97 ) { #should pry change to check for "this year" - $self->paydate("19$2-$1-01"); - } else { - $self->paydate("20$2-$1-01"); - } - } - - if ( $self->payname eq '' ) { - $self->payname( $self->first. " ". $self->getfield('last') ); - } else { - $self->payname =~ /^([\w \,\.\-\']+)$/ - or return "Illegal billing name"; - $self->payname($1); - } - - $self->tax =~ /^(Y?)$/ or return "Illegal tax"; - $self->tax($1); - - $self->otaker(getotaker); - - ''; #no error -} - -=item all_pkgs - -Returns all packages (see L<FS::cust_pkg>) for this customer. - -=cut - -sub all_pkgs { - my($self)=@_; - qsearch( 'cust_pkg', { 'custnum' => $self->custnum }); -} - -=item ncancelled_pkgs - -Returns all non-cancelled packages (see L<FS::cust_pkg>) for this customer. - -=cut - -sub ncancelled_pkgs { - my($self)=@_; - qsearch( 'cust_pkg', { - 'custnum' => $self->custnum, - 'cancel' => '', - }); -} - -=item bill OPTIONS - -Generates invoices (see L<FS::cust_bill>) for this customer. Usually used in -conjunction with the collect method. - -The only currently available option is `time', which bills the customer as if -it were that time. It is specified as a UNIX timestamp; see -L<perlfunc/"time">). Also see L<Time::Local> and L<Date::Parse> for conversion -functions. - -If there is an error, returns the error, otherwise returns false. - -=cut - -sub bill { - my($self,%options)=@_; - my($time) = $options{'time'} || $^T; - - my($error); - - #put below somehow? - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - - # find the packages which are due for billing, find out how much they are - # & generate invoice database. - - my($total_setup,$total_recur)=(0,0); - - my(@cust_bill_pkg); - - my($cust_pkg); - foreach $cust_pkg ( - qsearch('cust_pkg',{'custnum'=> $self->getfield('custnum') } ) - ) { - - bless($cust_pkg,"FS::cust_pkg"); - - next if ( $cust_pkg->getfield('cancel') ); - - #? to avoid use of uninitialized value errors... ? - $cust_pkg->setfield('bill', '') - unless defined($cust_pkg->bill); - - my($part_pkg)= - qsearchs('part_pkg',{'pkgpart'=> $cust_pkg->pkgpart } ); - - #so we don't modify cust_pkg record unnecessarily - my($cust_pkg_mod_flag)=0; - my(%hash)=$cust_pkg->hash; - my($old_cust_pkg)=create FS::cust_pkg(\%hash); - - # bill setup - my($setup)=0; - unless ( $cust_pkg->setup ) { - my($setup_prog)=$part_pkg->getfield('setup'); - my($cpt) = new Safe; - #$cpt->permit(); #what is necessary? - $cpt->share(qw($cust_pkg)); #can $cpt now use $cust_pkg methods? - $setup = $cpt->reval($setup_prog); - unless ( defined($setup) ) { - warn "Error reval-ing part_pkg->setup pkgpart ", - $part_pkg->pkgpart, ": $@"; - } else { - $cust_pkg->setfield('setup',$time); - $cust_pkg_mod_flag=1; - } - } - - #bill recurring fee - my($recur)=0; - my($sdate); - if ( $part_pkg->getfield('freq') > 0 && - ! $cust_pkg->getfield('susp') && - ( $cust_pkg->getfield('bill') || 0 ) < $time - ) { - my($recur_prog)=$part_pkg->getfield('recur'); - my($cpt) = new Safe; - #$cpt->permit(); #what is necessary? - $cpt->share(qw($cust_pkg)); #can $cpt now use $cust_pkg methods? - $recur = $cpt->reval($recur_prog); - unless ( defined($recur) ) { - warn "Error reval-ing part_pkg->recur pkgpart ", - $part_pkg->pkgpart, ": $@"; - } else { - #change this bit to use Date::Manip? - #$sdate=$cust_pkg->bill || time; - #$sdate=$cust_pkg->bill || $time; - $sdate=$cust_pkg->bill || $cust_pkg->setup || $time; - my($sec,$min,$hour,$mday,$mon,$year)= - (localtime($sdate) )[0,1,2,3,4,5]; - $mon += $part_pkg->getfield('freq'); - until ( $mon < 12 ) { $mon -= 12; $year++; } - $cust_pkg->setfield('bill',timelocal($sec,$min,$hour,$mday,$mon,$year)); - $cust_pkg_mod_flag=1; - } - } - - warn "setup is undefinded" unless defined($setup); - warn "recur is undefinded" unless defined($recur); - warn "cust_pkg bill is undefinded" unless defined($cust_pkg->bill); - - if ($cust_pkg_mod_flag) { - $error=$cust_pkg->replace($old_cust_pkg); - if ( $error ) { - 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 ({ - 'pkgnum' => $cust_pkg->pkgnum, - 'setup' => $setup, - 'recur' => $recur, - 'sdate' => $sdate, - 'edate' => $cust_pkg->bill, - }); - push @cust_bill_pkg, $cust_bill_pkg; - $total_setup += $setup; - $total_recur += $recur; - } - } - - } - - my($charged)=sprintf("%.2f",$total_setup + $total_recur); - - return '' if scalar(@cust_bill_pkg) == 0; - - unless ( $self->getfield('tax') eq 'Y' || - $self->getfield('tax') eq 'y' || - $self->getfield('payby') eq 'COMP' - ) { - my($cust_main_county) = qsearchs('cust_main_county',{ - 'county' => $self->getfield('county'), - 'state' => $self->getfield('state'), - } ); - my($tax) = sprintf("%.2f", - $charged * ( $cust_main_county->getfield('tax') / 100 ) - ); - $charged = sprintf("%.2f",$charged+$tax); - - my($cust_bill_pkg)=create FS::cust_bill_pkg ({ - 'pkgnum' => 0, - 'setup' => $tax, - 'recur' => 0, - 'sdate' => '', - 'edate' => '', - }); - push @cust_bill_pkg, $cust_bill_pkg; - } - - my($cust_bill) = create FS::cust_bill ( { - 'custnum' => $self->getfield('custnum'), - '_date' => $time, - 'charged' => $charged, - } ); - $error=$cust_bill->insert; - #shouldn't happen, but how else to handle this? (wrap me in eval, to catch - # fatal errors) - die "Error creating cust_bill record: $error!\n", - "Check updated but unbilled packages for customer", $self->custnum, "\n" - if $error; - - my($invnum)=$cust_bill->invnum; - my($cust_bill_pkg); - foreach $cust_bill_pkg ( @cust_bill_pkg ) { - $cust_bill_pkg->setfield('invnum',$invnum); - $error=$cust_bill_pkg->insert; - #shouldn't happen, but how else tohandle this? - die "Error creating cust_bill_pkg record: $error!\n", - "Check incomplete invoice ", $invnum, "\n" - if $error; - } - - ''; #no error -} - -=item collect OPTIONS - -(Attempt to) collect money for this customer's outstanding invoices (see -L<FS::cust_bill>). Usually used after the bill method. - -Depending on the value of `payby', this may print an invoice (`BILL'), charge -a credit card (`CARD'), or just add any necessary (pseudo-)payment (`COMP'). - -If there is an error, returns the error, otherwise returns false. - -Currently available options are: - -invoice_time - Use this time when deciding when to print invoices and -late notices on those invoices. The default is now. It is specified as a UNIX timestamp; see L<perlfunc/"time">). Also see L<Time::Local> and L<Date::Parse> -for conversion functions. - -batch_card - Set this true to batch cards (see L<cust_pay_batch>). By -default, cards are processed immediately, which will generate an error if -CyberCash is not installed. - -report_badcard - Set this true if you want bad card transactions to -return an error. By default, they don't. - -=cut - -sub collect { - my($self,%options)=@_; - my($invoice_time) = $options{'invoice_time'} || $^T; - - my($total_owed) = $self->balance; - return '' unless $total_owed > 0; #redundant????? - - #put below somehow? - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - - foreach my $cust_bill ( qsearch('cust_bill', { - 'custnum' => $self->getfield('custnum'), - } ) ) { - - #this has to be before next's - my($amount) = sprintf("%.2f", $total_owed < $cust_bill->owed - ? $total_owed - : $cust_bill->owed - ); - $total_owed = sprintf("%.2f",$total_owed-$amount); - - next unless $cust_bill->owed > 0; - - next if qsearchs('cust_pay_batch',{'invnum'=> $cust_bill->invnum }); - - #warn "invnum ". $cust_bill->invnum. " (owed ". $cust_bill->owed. ", amount $amount, total_owed $total_owed)"; - - next unless $amount > 0; - - if ( $self->getfield('payby') eq 'BILL' ) { - - #30 days 2592000 - my($since)=$invoice_time - ( $cust_bill->_date || 0 ); - #warn "$invoice_time ", $cust_bill->_date, " $since"; - if ( $since >= 0 #don't print future invoices - && ( $cust_bill->printed * 2592000 ) <= $since - ) { - - 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(%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"; - } - - } - - } elsif ( $self->getfield('payby') eq 'COMP' ) { - my($cust_pay) = create FS::cust_pay ( { - 'invnum' => $cust_bill->getfield('invnum'), - 'paid' => $amount, - '_date' => '', - 'payby' => 'COMP', - 'payinfo' => $self->getfield('payinfo'), - 'paybatch' => '' - } ); - my($error)=$cust_pay->insert; - return 'Error COMPing invnum #' . $cust_bill->getfield('invnum') . - ':' . $error if $error; - } elsif ( $self->getfield('payby') eq 'CARD' ) { - - if ( $options{'batch_card'} ne 'yes' ) { - - return "Real time card processing not enabled!" unless $processor; - - if ( $processor =~ /cybercash/ ) { - - #fix exp. date for cybercash - $self->getfield('paydate') =~ /^(\d+)\/\d*(\d{2})$/; - my($exp)="$1/$2"; - - my($paybatch)= $cust_bill->getfield('invnum') . - '-' . time2str("%y%m%d%H%M%S",time); - - my($payname)= $self->getfield('payname') || - $self->getfield('first') . ' ' .$self->getfield('last'); - - my($address)= $self->getfield('address1'); - $address .= ", " . $self->getfield('address2') - if $self->getfield('address2'); - - my($country) = $self->getfield('country') eq 'US' ? - 'USA' : $self->getfield('country'); - - my(@full_xaction)=($xaction, - 'Order-ID' => $paybatch, - 'Amount' => "usd $amount", - 'Card-Number' => $self->getfield('payinfo'), - 'Card-Name' => $payname, - 'Card-Address' => $address, - 'Card-City' => $self->getfield('city'), - 'Card-State' => $self->getfield('state'), - 'Card-Zip' => $self->getfield('zip'), - 'Card-Country' => $country, - 'Card-Exp' => $exp, - ); - - my(%result); - if ( $processor eq 'cybercash2' ) { - $^W=0; #CCLib isn't -w safe, ugh! - %result = &CCLib::sendmserver(@full_xaction); - $^W=1; - } elsif ( $processor eq 'cybercash3.2' ) { - %result = &CCMckDirectLib3_2::SendCC2_1Server(@full_xaction); - } else { - return "Unkonwn real-time processor $processor\n"; - } - - #if ( $result{'MActionCode'} == 7 ) { #cybercash smps v.1.1.3 - #if ( $result{'action-code'} == 7 ) { #cybercash smps v.2.1 - if ( $result{'MStatus'} eq 'success' ) { #cybercash smps v.2 or 3 - my($cust_pay) = create FS::cust_pay ( { - 'invnum' => $cust_bill->getfield('invnum'), - 'paid' => $amount, - '_date' => '', - 'payby' => 'CARD', - 'payinfo' => $self->getfield('payinfo'), - 'paybatch' => "$processor:$paybatch", - } ); - my($error)=$cust_pay->insert; - return 'Error applying payment, invnum #' . - $cust_bill->getfield('invnum') . ':' . $error if $error; - } elsif ( $result{'Mstatus'} ne 'failure-bad-money' - || $options{'report_badcard'} ) { - return 'Cybercash error, invnum #' . - $cust_bill->getfield('invnum') . ':' . $result{'MErrMsg'}; - } else { - return ''; - } - - } else { - return "Unkonwn real-time processor $processor\n"; - } - - } else { #batch card - -# my($cust_pay_batch) = create FS::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'), - 'first' => $self->getfield('first'), - 'address1' => $self->getfield('address1'), - 'address2' => $self->getfield('address2'), - 'city' => $self->getfield('city'), - 'state' => $self->getfield('state'), - 'zip' => $self->getfield('zip'), - 'country' => $self->getfield('country'), - 'trancode' => 77, - 'cardnum' => $self->getfield('payinfo'), - 'exp' => $self->getfield('paydate'), - 'payname' => $self->getfield('payname'), - 'amount' => $amount, - } ); -# my($error)=$cust_pay_batch->insert; - my($error)=$cust_pay_batch->add; - return "Error adding to cust_pay_batch: $error" if $error; - - } - - } else { - return "Unknown payment type ".$self->getfield('payby'); - } - - } - ''; - -} - -=item total_owed - -Returns the total owed for this customer on all invoices -(see L<FS::cust_bill>). - -=cut - -sub total_owed { - my($self) = @_; - my($total_bill) = 0; - my($cust_bill); - foreach $cust_bill ( qsearch('cust_bill', { - 'custnum' => $self->getfield('custnum'), - } ) ) { - $total_bill += $cust_bill->getfield('owed'); - } - sprintf("%.2f",$total_bill); -} - -=item total_credited - -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'), - } ) ) { - $total_credit += $cust_credit->getfield('credited'); - } - sprintf("%.2f",$total_credit); -} - -=item balance - -Returns the balance for this customer (total owed minus total credited). - -=cut - -sub balance { - my($self) = @_; - sprintf("%.2f",$self->total_bill - $self->total_credit); -} - -=back - -=head1 BUGS - -The delete method. - -It doesn't properly override FS::Record yet. - -hfields should be removed. - -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. - -=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. - -=head1 HISTORY - -ivan@voicenet.com 97-jul-28 - -Changed to standard Business::CreditCard -no more TableUtil -EXPORT_OK FS::Record's hfields -removed unique calls and locking (not needed here now) -wrapped the (now) optional fields in if statements in sub check (notyetdone!) -ivan@sisd.com 97-nov-12 - -updated paydate with SQL-type date info ivan@sisd.com 98-mar-5 - -Added export of datasrc from UID.pm for Pg6.3 -changed 'day' to 'daytime' because Pg6.3 reserves the day word - bmccane@maxbaud.net 98-apr-3 - -in ->create, s/svc_acct/cust_main/, now it should actually eliminate the -warnings it was meant to ivan@sisd.com 98-jul-16 - -don't require a phone number and allow '/' in company names -ivan@sisd.com 98-jul-18 - -use ut_ and rewrite &check, &*_pkgs ivan@sisd.com 98-sep-5 - -pod, merge with FS::Bill (about time!), total_owed, total_credited and balance -methods, cleaned collect method, source modifications no longer necessary to -enable cybercash, cybercash v3 support, don't need to import -FS::UID::{datasrc,checkruid} ivan@sisd.com 98-sep-19-21 - -=cut - -1; - - diff --git a/site_perl/cust_main_county.pm b/site_perl/cust_main_county.pm deleted file mode 100644 index f4b4595..0000000 --- a/site_perl/cust_main_county.pm +++ /dev/null @@ -1,161 +0,0 @@ -package FS::cust_main_county; - -use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(fields hfields qsearch qsearchs); - -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(hfields); - -=head1 NAME - -FS::cust_main_county - Object methods for cust_main_county objects - -=head1 SYNOPSIS - - use FS::cust_main_county; - - $record = create FS::cust_main_county \%hash; - $record = create FS::cust_main_county { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::cust_main_county object represents a tax rate, defined by locale. -FS::cust_main_county inherits from FS::Record. The following fields are -currently supported: - -=over 4 - -=item taxnum - primary key (assigned automatically for new tax rates) - -=item state - -=item county - -=item tax - percentage - -=back - -=head1 METHODS - -=over 4 - -=item create 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); -} - -=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, -returns the error, otherwise returns false. Called by the insert and replace -methods. - -=cut - -sub check { - my($self)=@_; - return "Not a cust_main_county record!" - unless $self->table eq "cust_main_county"; - my($recref) = $self->hashref; - - $self->ut_numbern('taxnum') - or $self->ut_text('state') - or $self->ut_textn('county') - or $self->ut_float('tax') - ; - -} - -=back - -=head1 BUGS - -It doesn't properly override FS::Record yet. - -A country field (and possibly a currency field) should be added. - -=head1 SEE ALSO - -L<FS::Record>, L<FS::cust_main>, L<FS::cust_bill>, schema.html from the base -documentation. - -=head1 HISTORY - -ivan@voicenet.com 97-dec-16 - -Changed check for 'tax' to use the new ut_float subroutine - bmccane@maxbaud.net 98-apr-3 - -pod ivan@sisd.com 98-sep-21 - -=cut - -1; - diff --git a/site_perl/cust_pay.pm b/site_perl/cust_pay.pm deleted file mode 100644 index 6e30c59..0000000 --- a/site_perl/cust_pay.pm +++ /dev/null @@ -1,235 +0,0 @@ -package FS::cust_pay; - -use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use Business::CreditCard; -use FS::Record qw(fields qsearchs); -use FS::cust_bill; - -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); - -=head1 NAME - -FS::cust_pay - Object methods for cust_pay objects - -=head1 SYNOPSIS - - use FS::cust_pay; - - $record = create FS::cust_pay \%hash; - $record = create FS::cust_pay { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::cust_pay object represents a payment. FS::cust_pay inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item paynum - primary key (assigned automatically for new payments) - -=item invnum - Invoice (see L<FS::cust_bill>) - -=item paid - Amount of this payment - -=item _date - specified as a UNIX timestamp; see L<perlfunc/"time">. Also see -L<Time::Local> and L<Date::Parse> for conversion functions. - -=item payby - `CARD' (credit cards), `BILL' (billing), or `COMP' (free) - -=item payinfo - card number, P.O.#, or comp issuer (4-8 lowercase alphanumerics; think username) - -=item paybatch - text field for tracking card processing - -=back - -=head1 METHODS - -=over 4 - -=item create 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); - -} - -=item insert - -Adds this payment to the databse, and updates the invoice (see -L<FS::cust_bill>). - -=cut - -sub insert { - my($self)=@_; - - my($error); - - $error=$self->check; - return $error if $error; - - my($old_cust_bill) = qsearchs('cust_bill', { - 'invnum' => $self->getfield('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 ); - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - - $error=$new_cust_bill -> replace($old_cust_bill); - return "Error modifying cust_bill: $error" if $error; - - $self->add; -} - -=item delete - -Currently unimplemented (accounting reasons). - -=cut - -sub delete { - return "Can't (yet?) delete cust_pay records!"; -#template code below -# my($self)=@_; -# -# $self->del; -} - -=item replace OLD_RECORD - -Currently unimplemented (accounting reasons). - -=cut - -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 - -Checks all fields to make sure this is a valid payment. If there is an error, -returns the error, otherwise returns false. Called by the insert method. - -=cut - -sub check { - my($self)=@_; - 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; - - $recref->{invnum} =~ /^(\d+)$/ or return "Illegal invnum"; - $recref->{invnum} = $1; - - $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; - - $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})$/ - 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/ ); - } else { - $recref->{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; - - } - - $recref->{paybatch} =~ /^([\w\-\:]*)$/ - or return "Illegal paybatch"; - $recref->{paybatch} = $1; - - ''; #no error - -} - -=back - -=head1 BUGS - -It doesn't properly override FS::Record yet. - -Delete and replace methods. - -=head1 SEE ALSO - -L<FS::Record>, L<FS::cust_bill>, schema.html from the base documentation. - -=head1 HISTORY - -ivan@voicenet.com 97-jul-1 - 25 - 29 - -new api ivan@sisd.com 98-mar-13 - -pod ivan@sisd.com 98-sep-21 - -=cut - -1; - diff --git a/site_perl/cust_pkg.pm b/site_perl/cust_pkg.pm deleted file mode 100644 index 7dc5aa7..0000000 --- a/site_perl/cust_pkg.pm +++ /dev/null @@ -1,507 +0,0 @@ -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::cust_svc; - -@ISA = qw(FS::Record Exporter); - -=head1 NAME - -FS::cust_pkg - Object methods for cust_pkg objects - -=head1 SYNOPSIS - - use FS::cust_pkg; - - $record = create FS::cust_pkg \%hash; - $record = create FS::cust_pkg { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - - $error = $record->cancel; - - $error = $record->suspend; - - $error = $record->unsuspend; - - $error = FS::cust_pkg::order( $custnum, \@pkgparts ); - $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] ); - -=head1 DESCRIPTION - -An FS::cust_pkg object represents a customer billing item. FS::cust_pkg -inherits from FS::Record. The following fields are currently supported: - -=over 4 - -=item pkgnum - primary key (assigned automatically for new billing items) - -=item custnum - Customer (see L<FS::cust_main>) - -=item pkgpart - Billing item definition (see L<FS::part_pkg>) - -=item setup - date - -=item bill - date - -=item susp - date - -=item expire - date - -=item cancel - date - -=item otaker - order taker (assigned automatically if null, see L<FS::UID>) - -=back - -Note: setup, bill, susp, expire and cancel are specified as UNIX timestamps; -see L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for -conversion functions. - -=head1 METHODS - -=over 4 - -=item create 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); -} - -=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)=@_; - - $self->check or - $self->add; -} - -=item delete - -Currently unimplemented. You don't want to delete billing items, because there -would then be no record the customer ever purchased the item. Instead, see -the cancel method. - -sub delete { - return "Can't delete cust_pkg records!"; -} - -=item replace OLD_RECORD - -Replaces the OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -Currently, custnum, setup, bill, susp, expire, and cancel may be changed. - -pkgpart may not be changed, but see the order subroutine. - -setup and bill are normally updated by calling the bill method of a customer -object (see L<FS::cust_main>). - -suspend is normally updated by the suspend and unsuspend methods. - -cancel is normally updated by the cancel method (and also the order subroutine -in some cases). - -=cut - -sub replace { - my($new,$old)=@_; - 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'); - 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); -} - -=item check - -Checks all fields to make sure this is a valid billing item. If there is an -error, returns the error, otherwise returns false. Called by the insert and -replace methods. - -=cut - -sub check { - my($self)=@_; - 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}}); - - $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; - - $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; - - ''; #no error -} - -=item cancel - -Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>) -in this package, then cancels the package itself (sets the cancel field to -now). - -If there is an error, returns the error, otherwise returns false. - -=cut - -sub cancel { - my($self)=@_; - my($error); - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - - my($cust_svc); - foreach $cust_svc ( - qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } ) - ) { - my($part_svc)= - qsearchs('part_svc',{'svcpart'=> $cust_svc->svcpart } ); - - $part_svc->getfield('svcdb') =~ /^([\w\-]+)$/ - or return "Illegal svcdb value in part_svc!"; - my($svcdb) = $1; - require "FS/$svcdb.pm"; - - my($svc) = qsearchs($svcdb,{'svcnum' => $cust_svc->svcnum } ); - if ($svc) { - 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); - return $error if $error; - } - - ''; #no errors -} - -=item suspend - -Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this -package, then suspends the package itself (sets the susp field to now). - -If there is an error, returns the error, otherwise returns false. - -=cut - -sub suspend { - my($self)=@_; - my($error); - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - - my($cust_svc); - foreach $cust_svc ( - qsearch('cust_svc',{'pkgnum'=> $self->getfield('pkgnum') } ) - ) { - my($part_svc)= - qsearchs('part_svc',{'svcpart'=> $cust_svc->getfield('svcpart') } ); - - $part_svc->getfield('svcdb') =~ /^([\w\-]+)$/ - or return "Illegal svcdb value in part_svc!"; - my($svcdb) = $1; - require "FS/$svcdb.pm"; - - my($svc) = qsearchs($svcdb,{'svcnum' => $cust_svc->getfield('svcnum') } ); - - if ($svc) { - bless($svc,"FS::$svcdb"); - $error = $svc->suspend; - return $error if $error; - } - - } - - unless ( $self->getfield('susp') ) { - my(%hash) = $self->hash; - $hash{'susp'}=$^T; - my($new) = create FS::cust_pkg ( \%hash ); - $error=$new->replace($self); - return $error if $error; - } - - ''; #no errors -} - -=item unsuspend - -Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this -package, then unsuspends the package itself (clears the susp field). - -If there is an error, returns the error, otherwise returns false. - -=cut - -sub unsuspend { - my($self)=@_; - my($error); - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - - my($cust_svc); - foreach $cust_svc ( - qsearch('cust_svc',{'pkgnum'=> $self->getfield('pkgnum') } ) - ) { - my($part_svc)= - qsearchs('part_svc',{'svcpart'=> $cust_svc->getfield('svcpart') } ); - - $part_svc->getfield('svcdb') =~ /^([\w\-]+)$/ - or return "Illegal svcdb value in part_svc!"; - my($svcdb) = $1; - require "FS/$svcdb.pm"; - - my($svc) = qsearchs($svcdb,{'svcnum' => $cust_svc->getfield('svcnum') } ); - if ($svc) { - bless($svc,"FS::$svcdb"); - $error = $svc->unsuspend; - return $error if $error; - } - - } - - unless ( ! $self->getfield('susp') ) { - my(%hash) = $self->hash; - $hash{'susp'}=''; - my($new) = create FS::cust_pkg ( \%hash ); - $error=$new->replace($self); - return $error if $error; - } - - ''; #no errors -} - -=back - -=head1 SUBROUTINES - -=over 4 - -=item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF ] - -CUSTNUM is a customer (see L<FS::cust_main>) - -PKGPARTS is a list of pkgparts specifying the the billing item definitions (see -L<FS::part_pkg>) to order for this customer. Duplicates are of course -permitted. - -REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to -remove for this customer. The services (see L<FS::cust_svc>) are moved to the -new billing items. An error is returned if this is not possible (see -L<FS::pkg_svc>). - -=cut - -sub order { - my($custnum,$pkgparts,$remove_pkgnums)=@_; - - my(%part_pkg); - # generate %part_pkg - # $part_pkg{$pkgpart} is true iff $custnum may purchase $pkgpart - my($cust_main)=qsearchs('cust_main',{'custnum'=>$custnum}); - my($agent)=qsearchs('agent',{'agentnum'=> $cust_main->agentnum }); - - my($type_pkgs); - foreach $type_pkgs ( qsearch('type_pkgs',{'typenum'=> $agent->typenum }) ) { - my($pkgpart)=$type_pkgs->pkgpart; - $part_pkg{$pkgpart}++; - } - # - - my(%svcnum); - # generate %svcnum - # for those packages being removed: - #@{ $svcnum{$svcpart} } goes from a svcpart to a list of FS::Record - # objects (table eq 'cust_svc') - my($pkgnum); - foreach $pkgnum ( @{$remove_pkgnums} ) { - my($cust_svc); - foreach $cust_svc (qsearch('cust_svc',{'pkgnum'=>$pkgnum})) { - push @{ $svcnum{$cust_svc->getfield('svcpart')} }, $cust_svc; - } - } - - my(@cust_svc); - #generate @cust_svc - # for those packages the customer is purchasing: - # @{$pkgparts} is a list of said packages, by pkgpart - # @cust_svc is a corresponding list of lists of FS::Record objects - my($pkgpart); - foreach $pkgpart ( @{$pkgparts} ) { - return "Customer not permitted to purchase pkgpart $pkgpart!" - unless $part_pkg{$pkgpart}; - push @cust_svc, [ - map { - ( $svcnum{$_} && @{ $svcnum{$_} } ) ? shift @{ $svcnum{$_} } : (); - } (split(/,/, - qsearchs('part_pkg',{'pkgpart'=>$pkgpart})->getfield('services') - )) - ]; - } - - #check for leftover services - foreach (keys %svcnum) { - next unless @{ $svcnum{$_} }; - return "Leftover services!"; - } - - #no leftover services, let's make changes. - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - - #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; - my(%hash) = $old->hash; - $hash{'cancel'}=$^T; - my($new) = create FS::cust_pkg ( \%hash ); - my($error)=$new->replace($old); - return $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 ( { - 'custnum' => $custnum, - 'pkgpart' => $pkgpart, - } ); - my($error) = $new->insert; - return $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($error)=$new->replace($cust_svc); - return $error if $error; - } - } - - ''; #no errors -} - -=back - -=head1 BUGS - -It doesn't properly override FS::Record yet. - -sub order is not OO. Perhaps it should be moved to FS::cust_main and made so? - -In sub order, the @pkgparts array (passed by reference) is clobbered. - -Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard -method to pass dates to the recur_prog expression, it should do so. - -=head1 SEE ALSO - -L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc> -, L<FS::pkg_svc>, schema.html from the base documentation - -=head1 HISTORY - -ivan@voicenet.com 97-jul-1 - 21 - -fixed for new agent->agent_type->type_pkgs in &order ivan@sisd.com 98-mar-7 - -pod ivan@sisd.com 98-sep-21 - -=cut - -1; - diff --git a/site_perl/cust_refund.pm b/site_perl/cust_refund.pm deleted file mode 100644 index a30f217..0000000 --- a/site_perl/cust_refund.pm +++ /dev/null @@ -1,233 +0,0 @@ -package FS::cust_refund; - -use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use Business::CreditCard; -use FS::Record qw(fields qsearchs); -use FS::UID qw(getotaker); -use FS::cust_credit; - -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); - -=head1 NAME - -FS::cust_refund - Object method for cust_refund objects - -=head1 SYNOPSIS - - use FS::cust_refund; - - $record = create FS::cust_refund \%hash; - $record = create FS::cust_refund { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::cust_refund represents a refund. FS::cust_refund inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item refundnum - primary key (assigned automatically for new refunds) - -=item crednum - Credit (see L<FS::cust_credit>) - -=item refund - Amount of the refund - -=item _date - specified as a UNIX timestamp; see L<perlfunc/"time">. Also see -L<Time::Local> and L<Date::Parse> for conversion functions. - -=item payby - `CARD' (credit cards), `BILL' (billing), or `COMP' (free) - -=item payinfo - card number, P.O.#, or comp issuer (4-8 lowercase alphanumerics; think username) - -=item otaker - order taker (assigned automatically, see L<FS::UID>) - -=back - -=head1 METHODS - -=over 4 - -=item create 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); - -} - -=item insert - -Adds this refund to the database, and updates the credit (see -L<FS::cust_credit>). - -=cut - -sub insert { - my($self)=@_; - - my($error); - - $error=$self->check; - return $error if $error; - - my($old_cust_credit) = qsearchs('cust_credit', { - 'crednum' => $self->getfield('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 ); - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - - $error=$new_cust_credit -> replace($old_cust_credit); - return "Error modifying cust_credit: $error" if $error; - - $self->add; -} - -=item delete - -Currently unimplemented (accounting reasons). - -=cut - -sub delete { - return "Can't (yet?) delete cust_refund records!"; -#template code below -# my($self)=@_; -# -# $self->del; -} - -=item replace OLD_RECORD - -Currently unimplemented (accounting reasons). - -=cut - -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 - -Checks all fields to make sure this is a valid refund. If there is an error, -returns the error, otherwise returns false. Called by the insert method. - -=cut - -sub check { - my($self)=@_; - return "Not a cust_refund record!" unless $self->table eq "cust_refund"; - - my $error = - $self->ut_number('refundnum') - || $self->ut_number('crednum') - || $self->ut_money('amount') - || $self->ut_numbern('_date') - ; - return $error if $error; - - my($recref) = $self->hashref; - - $recref->{_date} ||= time; - - $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})$/ - 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/ ); - } else { - $recref->{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; - - } - - $self->otaker(getotaker); - - ''; #no error -} - -=back - -=head1 BUGS - -It doesn't properly override FS::Record yet. - -Delete and replace methods. - -=head1 SEE ALSO - -L<FS::Record>, L<FS::cust_credit>, schema.html from the base documentation. - -=head1 HISTORY - -ivan@sisd.com 98-mar-18 - -->create had wrong tablename ivan@sisd.com 98-jun-16 -(finish me!) - -pod and finish up ivan@sisd.com 98-sep-21 - -=cut - -1; - diff --git a/site_perl/cust_svc.pm b/site_perl/cust_svc.pm deleted file mode 100644 index 1d5051b..0000000 --- a/site_perl/cust_svc.pm +++ /dev/null @@ -1,168 +0,0 @@ -package FS::cust_svc; - -use strict; -use vars qw(@ISA); -use Exporter; -use FS::Record qw(fields qsearchs); - -@ISA = qw(FS::Record Exporter); - -=head1 NAME - -FS::cust_svc - Object method for cust_svc objects - -=head1 SYNOPSIS - - use FS::cust_svc; - - $record = create FS::cust_svc \%hash - $record = create FS::cust_svc { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::cust_svc represents a service. FS::cust_svc inherits from FS::Record. -The following fields are currently supported: - -=over 4 - -=item svcnum - primary key (assigned automatically for new services) - -=item pkgnum - Package (see L<FS::cust_pkg>) - -=item svcpart - Service definition (see L<FS::part_svc>) - -=back - -=head1 METHODS - -=over 4 - -=item create HASHREF - -Creates a new service. To add the refund to the database, see L<"insert">. -Services are normally created by creating FS::svc_ objects (see -L<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); -} - -=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 -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, -returns the error, otehrwise returns false. Called by the insert and -replace methods. - -=cut - -sub check { - my($self)=@_; - return "Not a cust_svc record!" unless $self->table eq "cust_svc"; - my($recref) = $self->hashref; - - $recref->{svcnum} =~ /^(\d*)$/ or return "Illegal svcnum"; - $recref->{svcnum}=$1; - - $recref->{pkgnum} =~ /^(\d*)$/ or return "Illegal pkgnum"; - $recref->{pkgnum}=$1; - return "Unknown pkgnum" unless - ! $recref->{pkgnum} || - qsearchs('cust_pkg',{'pkgnum'=>$recref->{pkgnum}}); - - $recref->{svcpart} =~ /^(\d+)$/ or return "Illegal svcpart"; - $recref->{svcpart}=$1; - return "Unknown svcpart" unless - qsearchs('part_svc',{'svcpart'=>$recref->{svcpart}}); - - ''; #no error -} - -=back - -=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). - -=head1 SEE ALSO - -L<FS::Record>, L<FS::cust_pkg>, L<FS::part_svc>, L<FS::pkg_svc>, -schema.html from the base documentation - -=head1 HISTORY - -ivan@voicenet.com 97-jul-10,14 - -no TableUtil, no FS::Lock ivan@sisd.com 98-mar-7 - -pod ivan@sisd.com 98-sep-21 - -=cut - -1; - diff --git a/site_perl/dbdef.pm b/site_perl/dbdef.pm deleted file mode 100644 index ac31bff..0000000 --- a/site_perl/dbdef.pm +++ /dev/null @@ -1,174 +0,0 @@ -package FS::dbdef; - -use strict; -use vars qw(@ISA); -use Exporter; -use Carp; -use FreezeThaw qw(freeze thaw cmpStr); -use FS::dbdef_table; -use FS::dbdef_unique; -use FS::dbdef_index; -use FS::dbdef_column; - -@ISA = qw(Exporter); - -=head1 NAME - -FS::dbdef - Database objects - -=head1 SYNOPSIS - - use FS::dbdef; - - $dbdef = new FS::dbdef (@dbdef_table_objects); - $dbdef = load FS::dbdef "filename"; - - $dbdef->save("filename"); - - $dbdef->addtable($dbdef_table_object); - - @table_names = $dbdef->tables; - - $FS_dbdef_table_object = $dbdef->table; - -=head1 DESCRIPTION - -FS::dbdef objects are collections of FS::dbdef_table objects and represnt -a database (a collection of tables). - -=head1 METHODS - -=over 4 - -=item new TABLE, TABLE, ... - -Creates a new FS::dbdef object - -=cut - -sub new { - my($proto,@tables)=@_; - my(%tables)=map { $_->name, $_ } @tables; #check for duplicates? - - my($class) = ref($proto) || $proto; - my($self) = { - 'tables' => \%tables, - }; - - bless ($self, $class); - -} - -=item load FILENAME - -Loads an FS::dbdef object from a file. - -=cut - -sub load { - my($proto,$file)=@_; #use $proto ? - open(FILE,"<$file") or die "Can't open $file: $!"; - my($string)=join('',<FILE>); #can $string have newlines? pry not? - close FILE or die "Can't close $file: $!"; - my($self)=thaw $string; - #no bless needed? - $self; -} - -=item save FILENAME - -Saves an FS::dbdef object to a file. - -=cut - -sub save { - my($self,$file)=@_; - my($string)=freeze $self; - open(FILE,">$file") or die "Can't open $file: $!"; - print FILE $string; - close FILE or die "Can't close file: $!"; - my($check_self)=thaw $string; - die "Verify error: Can't freeze and thaw dbdef $self" - if (cmpStr($self,$check_self)); -} - -=item addtable TABLE - -Adds this FS::dbdef_table object. - -=cut - -sub addtable { - my($self,$table)=@_; - ${$self->{'tables'}}{$table->name}=$table; #check for dupliates? -} - -=item tables - -Returns the names of all tables. - -=cut - -sub tables { - my($self)=@_; - keys %{$self->{'tables'}}; -} - -=item table TABLENAME - -Returns the named FS::dbdef_table object. - -=cut - -sub table { - my($self,$table)=@_; - $self->{'tables'}->{$table}; -} - -=head1 BUGS - -Each FS::dbdef object should have a name which corresponds to its name within -the SQL database engine. - -=head1 SEE ALSO - -L<FS::dbdef_table>, L<FS::Record>, - -=head1 HISTORY - -beginning of abstraction into a class (not really) - -ivan@sisd.com 97-dec-4 - -added primary_key -ivan@sisd.com 98-jan-20 - -added datatype (very kludgy and needs to be cleaned) -ivan@sisd.com 98-feb-21 - -perltrap (sigh) masked by mysql 3.20->3,21 ivan@sisd.com 98-mar-2 - -Change 'type' to 'atype' in agent_type -Changed attributes to special words which are changed in fs-setup - ie. double(10,2) <=> MONEYTYPE -Changed order of some of the field definitions because Pg6.3 is picky -Changed 'day' to 'daytime' in cust_main -Changed type of tax from tinyint to real -Change 'password' to '_password' in svc_acct -Pg6.3 does not allow 'field char(x) NULL' - bmccane@maxbaud.net 98-apr-3 - -rewrite: now properly OO. See also FS::dbdef_{table,column,unique,index} - -ivan@sisd.com 98-apr-17 - -gained some extra functions ivan@sisd.com 98-may-11 - -now knows how to Freeze and Thaw itself ivan@sisd.com 98-jun-2 - -pod ivan@sisd.com 98-sep-23 - -=cut - -1; - diff --git a/site_perl/dbdef_colgroup.pm b/site_perl/dbdef_colgroup.pm deleted file mode 100644 index 64f2e30..0000000 --- a/site_perl/dbdef_colgroup.pm +++ /dev/null @@ -1,107 +0,0 @@ -package FS::dbdef_colgroup; - -use strict; -use vars qw(@ISA); - -@ISA = qw(Exporter); - -=head1 NAME - -FS::dbdef_colgroup - Column group objects - -=head1 SYNOPSIS - - use FS::dbdef_colgroup; - - $colgroup = new FS::dbdef_colgroup ( $lol ); - $colgroup = new FS::dbdef_colgroup ( - [ - [ 'single_column' ], - [ 'multiple_columns', 'another_column', ], - ] - ); - - @sql_lists = $colgroup->sql_list; - - @singles = $colgroup->singles; - -=head1 DESCRIPTION - -FS::dbdef_colgroup objects represent sets of sets of columns. - -=head1 METHODS - -=over 4 - -=item new - -Creates a new FS::dbdef_colgroup object. - -=cut - -sub new { - my($proto, $lol) = @_; - - my $class = ref($proto) || $proto; - my $self = { - 'lol' => $lol, - }; - - bless ($self, $class); - -} - -=item sql_list - -Returns a flat list of comma-separated values, for SQL statements. - -=cut - -sub sql_list { #returns a flat list of comman-separates lists (for sql) - my($self)=@_; - grep $_ ne '', map join(', ', @{$_}), @{$self->{'lol'}}; -} - -=item singles - -Returns a flat list of all single item lists. - -=cut - -sub singles { #returns single-field groups as a flat list - my($self)=@_; - #map ${$_}[0], grep scalar(@{$_}) == 1, @{$self->{'lol'}}; - map { - ${$_}[0] =~ /^(\w+)$/ - #aah! - or die "Illegal column ", ${$_}[0], " in colgroup!"; - $1; - } grep scalar(@{$_}) == 1, @{$self->{'lol'}}; -} - -=back - -=head1 BUGS - -=head1 SEE ALSO - -L<FS::dbdef_table>, L<FS::dbdef_unique>, L<FS::dbdef_index>, -L<FS::dbdef_column>, L<FS::dbdef>, L<perldsc> - -=head1 HISTORY - -class for dealing with groups of groups of columns (used as a base class by -FS::dbdef_{unique,index} ) - -ivan@sisd.com 98-apr-19 - -added singles, fixed sql_list to skip empty lists ivan@sisd.com 98-jun-2 - -untaint things we're returning in sub singels ivan@sisd.com 98-jun-4 - -pod ivan@sisd.com 98-sep-24 - -=cut - -1; - diff --git a/site_perl/dbdef_column.pm b/site_perl/dbdef_column.pm deleted file mode 100644 index 023b57d..0000000 --- a/site_perl/dbdef_column.pm +++ /dev/null @@ -1,175 +0,0 @@ -package FS::dbdef_column; - -use strict; -#use Carp; -use Exporter; -use vars qw(@ISA); - -@ISA = qw(Exporter); - -=head1 NAME - -FS::dbdef_column - Column object - -=head1 SYNOPSIS - - use FS::dbdef_column; - - $column_object = new FS::dbdef_column ( $name, $sql_type, '' ); - $column_object = new FS::dbdef_column ( $name, $sql_type, 'NULL' ); - $column_object = new FS::dbdef_column ( $name, $sql_type, '', $length ); - $column_object = new FS::dbdef_column ( $name, $sql_type, 'NULL', $length ); - - $name = $column_object->name; - $column_object->name ( 'name' ); - - $name = $column_object->type; - $column_object->name ( 'sql_type' ); - - $name = $column_object->null; - $column_object->name ( 'NOT NULL' ); - - $name = $column_object->length; - $column_object->name ( $length ); - - $sql_line = $column->line; - $sql_line = $column->line $datasrc; - -=head1 DESCRIPTION - -FS::dbdef::column objects represend columns in tables (see L<FS::dbdef_table>). - -=head1 METHODS - -=over 4 - -=item new - -Creates a new FS::dbdef_column object. - -=cut - -sub new { - my($proto,$name,$type,$null,$length)=@_; - - #croak "Illegal name: $name" if grep $name eq $_, @reserved_words; - - $null =~ s/^NOT NULL$//i; - - my $class = ref($proto) || $proto; - my $self = { - 'name' => $name, - 'type' => $type, - 'null' => $null, - 'length' => $length, - }; - - bless ($self, $class); - -} - -=item name - -Returns or sets the column name. - -=cut - -sub name { - my($self,$value)=@_; - if ( defined($value) ) { - #croak "Illegal name: $name" if grep $name eq $_, @reserved_words; - $self->{'name'} = $value; - } else { - $self->{'name'}; - } -} - -=item type - -Returns or sets the column type. - -=cut - -sub type { - my($self,$value)=@_; - if ( defined($value) ) { - $self->{'type'} = $value; - } else { - $self->{'type'}; - } -} - -=item null - -Returns or sets the column null flag. - -=cut - -sub null { - my($self,$value)=@_; - if ( defined($value) ) { - $value =~ s/^NOT NULL$//i; - $self->{'null'} = $value; - } else { - $self->{'null'}; - } -} - -=item type - -Returns or sets the column length. - -=cut - -sub length { - my($self,$value)=@_; - if ( defined($value) ) { - $self->{'length'} = $value; - } else { - $self->{'length'}; - } -} - -=item line [ $datasrc ] - -Returns an SQL column definition. - -If passed a DBI $datasrc specifying L<DBD::mysql>, will use MySQL-specific -syntax. Non-standard syntax for other engines (if applicable) may also be -supported in the future. - -=cut - -sub line { - my($self,$datasrc)=@_; - my($null)=$self->null; - $null ||= "NOT NULL" if $datasrc =~ /mysql/; #yucky mysql hack - join(' ', - $self->name, - $self->type. ( $self->length ? '('.$self->length.')' : '' ), - $null, - ); -} - -=back - -=head1 BUGS - -=head1 SEE ALSO - -L<FS::dbdef_table>, L<FS::dbdef>, L<DBI> - -=head1 HISTORY - -class for dealing with column definitions - -ivan@sisd.com 98-apr-17 - -now methods can be used to get or set data ivan@sisd.com 98-may-11 - -mySQL-specific hack for null (what should be default?) ivan@sisd.com 98-jun-2 - -=cut - -1; - diff --git a/site_perl/dbdef_index.pm b/site_perl/dbdef_index.pm deleted file mode 100644 index 2097db1..0000000 --- a/site_perl/dbdef_index.pm +++ /dev/null @@ -1,43 +0,0 @@ -package FS::dbdef_index; - -use strict; -use vars qw(@ISA); -use FS::dbdef_colgroup; - -@ISA=qw(FS::dbdef_colgroup); - -=head1 NAME - -FS::dbdef_unique.pm - Index object - -=head1 SYNOPSIS - - use FS::dbdef_index; - - # see FS::dbdef_colgroup methods - -=head1 DESCRIPTION - -FS::dbdef_unique objects represent the (non-unique) indices of a table -(L<FS::dbdef_table>). FS::dbdef_unique inherits from FS::dbdef_colgroup. - -=head1 BUGS - -Is this empty subclass needed? - -=head1 SEE ALSO - -L<FS::dbdef_colgroup>, L<FS::dbdef_record>, L<FS::Record> - -=head1 HISTORY - -class for dealing with index definitions - -ivan@sisd.com 98-apr-19 - -pod ivan@sisd.com 98-sep-24 - -=cut - -1; - diff --git a/site_perl/dbdef_table.pm b/site_perl/dbdef_table.pm deleted file mode 100644 index bc1454d..0000000 --- a/site_perl/dbdef_table.pm +++ /dev/null @@ -1,249 +0,0 @@ -package FS::dbdef_table; - -use strict; -#use Carp; -use Exporter; -use vars qw(@ISA); -use FS::dbdef_column; - -@ISA = qw(Exporter); - -=head1 NAME - -FS::dbdef_table - Table objects - -=head1 SYNOPSIS - - use FS::dbdef_table; - - $dbdef_table = new FS::dbdef_table ( - "table_name", - "primary_key", - $FS_dbdef_unique_object, - $FS_dbdef_index_object, - @FS_dbdef_column_objects, - ); - - $dbdef_table->addcolumn ( $FS_dbdef_column_object ); - - $table_name = $dbdef_table->name; - $dbdef_table->name ("table_name"); - - $table_name = $dbdef_table->primary_keye; - $dbdef_table->primary_key ("primary_key"); - - $FS_dbdef_unique_object = $dbdef_table->unique; - $dbdef_table->unique ( $FS_dbdef_unique_object ); - - $FS_dbdef_index_object = $dbdef_table->index; - $dbdef_table->index ( $FS_dbdef_index_object ); - - @column_names = $dbdef->columns; - - $FS_dbdef_column_object = $dbdef->column; - - @sql_statements = $dbdef->sql_create_table; - @sql_statements = $dbdef->sql_create_table $datasrc; - -=head1 DESCRIPTION - -FS::dbdef_table objects represent a single database table. - -=head1 METHODS - -=over 4 - -=item new - -Creates a new FS::dbdef_table object. - -=cut - -sub new { - my($proto,$name,$primary_key,$unique,$index,@columns)=@_; - - my(%columns) = map { $_->name, $_ } @columns; - - #check $primary_key, $unique and $index to make sure they are $columns ? - # (and sanity check?) - - my $class = ref($proto) || $proto; - my $self = { - 'name' => $name, - 'primary_key' => $primary_key, - 'unique' => $unique, - 'index' => $index, - 'columns' => \%columns, - }; - - bless ($self, $class); - -} - -=item addcolumn - -Adds this FS::dbdef_column object. - -=cut - -sub addcolumn { - my($self,$column)=@_; - ${$self->{'columns'}}{$column->name}=$column; #sanity check? -} - -=item name - -Returns or sets the table name. - -=cut - -sub name { - my($self,$value)=@_; - if ( defined($value) ) { - $self->{name} = $value; - } else { - $self->{name}; - } -} - -=item primary_key - -Returns or sets the primary key. - -=cut - -sub primary_key { - my($self,$value)=@_; - if ( defined($value) ) { - $self->{primary_key} = $value; - } else { - #$self->{primary_key}; - #hmm. maybe should untaint the entire structure when it comes off disk - # cause if you don't trust that, ? - $self->{primary_key} =~ /^(\w*)$/ - #aah! - or die "Illegal primary key ", $self->{primary_key}, " in dbdef!\n"; - $1; - } -} - -=item unique - -Returns or sets the FS::dbdef_unique object. - -=cut - -sub unique { - my($self,$value)=@_; - if ( defined($value) ) { - $self->{unique} = $value; - } else { - $self->{unique}; - } -} - -=item index - -Returns or sets the FS::dbdef_index object. - -=cut - -sub index { - my($self,$value)=@_; - if ( defined($value) ) { - $self->{'index'} = $value; - } else { - $self->{'index'}; - } -} - -=item columns - -Returns a list consisting of the names of all columns. - -=cut - -sub columns { - my($self)=@_; - keys %{$self->{'columns'}}; -} - -=item column "column" - -Returns the column object (see L<FS::dbdef_column>) for "column". - -=cut - -sub column { - my($self,$column)=@_; - $self->{'columns'}->{$column}; -} - -=item sql_create_table [ $datasrc ] - -Returns an array of SQL statments to create this table. - -If passed a DBI $datasrc specifying L<DBD::mysql>, will use MySQL-specific -syntax. Non-standard syntax for other engines (if applicable) may also be -supported in the future. - -=cut - -sub sql_create_table { - my($self,$datasrc)=@_; - - my(@columns)=map { $self->column($_)->line($datasrc) } $self->columns; - push @columns, "PRIMARY KEY (". $self->primary_key. ")" - if $self->primary_key; - if ( $datasrc =~ /mysql/ ) { #yucky mysql hack - push @columns, map "UNIQUE ($_)", $self->unique->sql_list; - push @columns, map "INDEX ($_)", $self->index->sql_list; - } - - "CREATE TABLE ". $self->name. " ( ". join(", ", @columns). " )", - ( map { - my($index) = $_ . "_index"; - $index =~ s/,\s*/_/g; - "CREATE UNIQUE INDEX $index ON ". $self->name. " ($_)" - } $self->unique->sql_list ), - ( map { - my($index) = $_ . "_index"; - $index =~ s/,\s*/_/g; - "CREATE INDEX $index ON ". $self->name. " ($_)" - } $self->index->sql_list ), - ; - - -} - -=back - -=head1 BUGS - -=head1 SEE ALSO - -L<FS::dbdef>, L<FS::dbdef_unique>, L<FS::dbdef_index>, L<FS::dbdef_unique>, -L<DBI> - -=head1 HISTORY - -class for dealing with table definitions - -ivan@sisd.com 98-apr-18 - -gained extra functions (should %columns be an IxHash?) -ivan@sisd.com 98-may-11 - -sql_create_table returns a list of statments, not just one, and now it -does indices (plus mysql hack) ivan@sisd.com 98-jun-2 - -untaint primary_key... hmm. is this a hack around a bigger problem? -looks like, did the same thing singles in colgroup! -ivan@sisd.com 98-jun-4 - -pod ivan@sisd.com 98-sep-24 - -=cut - -1; - diff --git a/site_perl/dbdef_unique.pm b/site_perl/dbdef_unique.pm deleted file mode 100644 index 4ec40de..0000000 --- a/site_perl/dbdef_unique.pm +++ /dev/null @@ -1,44 +0,0 @@ -package FS::dbdef_unique; - -use strict; -use vars qw(@ISA); -use FS::dbdef_colgroup; - -@ISA=qw(FS::dbdef_colgroup); - -=head1 NAME - -FS::dbdef_unique.pm - Unique object - -=head1 SYNOPSIS - - use FS::dbdef_unique; - - # see FS::dbdef_colgroup methods - -=head1 DESCRIPTION - -FS::dbdef_unique objects represent the unique indices of a database table -(L<FS::dbdef_table>). FS::dbdef_unique inherits from FS::dbdef_colgroup. - -=head1 BUGS - -Is this empty subclass needed? - -=head1 SEE ALSO - -L<FS::dbdef_colgroup>, L<FS::dbdef_record>, L<FS::Record> - -=head1 HISTORY - -class for dealing with unique definitions - -ivan@sisd.com 98-apr-19 - -pod ivan@sisd.com 98-sep-24 - -=cut - -1; - - diff --git a/site_perl/part_pkg.pm b/site_perl/part_pkg.pm deleted file mode 100644 index d1c12e4..0000000 --- a/site_perl/part_pkg.pm +++ /dev/null @@ -1,168 +0,0 @@ -package FS::part_pkg; - -use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(fields hfields); - -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(hfields fields); - -=head1 NAME - -FS::part_pkg - Object methods for part_pkg objects - -=head1 SYNOPSIS - - use FS::part_pkg; - - $record = create FS::part_pkg \%hash - $record = create FS::part_pkg { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::part_pkg represents a billing item definition. FS::part_pkg inherits -from FS::Record. The following fields are currently supported: - -=over 4 - -=item pkgpart - primary key (assigned automatically for new billing item definitions) - -=item pkg - Text name of this billing item definition (customer-viewable) - -=item comment - Text name of this billing item definition (non-customer-viewable) - -=item setup - Setup fee - -=item freq - Frequency of recurring fee - -=item recur - Recurring fee - -=back - -setup and recur are evaluated as Safe perl expressions. You can use numbers -just as you would normally. More advanced semantics are not yet defined. - -=head1 METHODS - -=over 4 - -=item create 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)=@_; - - #now in FS::Record::new - #my($field); - #foreach $field (fields('part_pkg')) { - # $hashref->{$field}='' unless defined $hashref->{$field}; - #} - - $proto->new('part_pkg',$hashref); -} - -=item insert - -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. - -=cut - -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; -} - -=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 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 -there is an error, returns the error, otherwise returns false. Called by the -insert and replace methods. - -=cut - -sub check { - my($self)=@_; - return "Not a part_pkg record!" unless $self->table eq "part_pkg"; - - $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') - ; - -} - -=back - -=head1 BUGS - -It doesn't properly override FS::Record yet. - -The delete method is unimplemented. - -setup and recur semantics are not yet defined (and are implemented in -FS::cust_bill. hmm.). - -=head1 SEE ALSO - -L<FS::Record>, L<FS::cust_pkg>, L<FS::type_pkgs>, L<FS::pkg_svc>, L<Safe>. -schema.html from the base documentation. - -=head1 HISTORY - -ivan@sisd.com 97-dec-5 - -pod ivan@sisd.com 98-sep-21 - -=cut - -1; - diff --git a/site_perl/part_referral.pm b/site_perl/part_referral.pm deleted file mode 100644 index 1b4a1b6..0000000 --- a/site_perl/part_referral.pm +++ /dev/null @@ -1,155 +0,0 @@ -package FS::part_referral; - -use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(fields qsearchs); - -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); - -=head1 NAME - -FS::part_referral - Object methods for part_referral objects - -=head1 SYNOPSIS - - use FS::part_referral; - - $record = create FS::part_referral \%hash - $record = create FS::part_referral { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::part_referral represents a referral - where a customer heard of your -services. This can be used to track the effectiveness of a particular piece of -advertising, for example. FS::part_referral inherits from FS::Record. The -following fields are currently supported: - -=over 4 - -=item refnum - primary key (assigned automatically for new referrals) - -=item referral - Text name of this referral - -=back - -=head1 METHODS - -=over 4 - -=item create 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); -} - -=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. - -=cut - -sub delete { - my($self)=@_; - return "Can't (yet?) delete part_referral records"; - #$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 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, -returns the error, otherwise returns false. Called by the insert and replace -methods. - -=cut - -sub check { - my($self)=@_; - return "Not a part_referral record!" unless $self->table eq "part_referral"; - - my($error)= - $self->ut_numbern('refnum') - or $self->ut_text('referral') - ; - return $error if $error; - - ''; - -} - -=back - -=head1 BUGS - -It doesn't properly override FS::Record yet. - -The delete method is unimplemented. - -=head1 SEE ALSO - -L<FS::Record>, L<FS::cust_main>, schema.html from the base documentation. - -=head1 HISTORY - -Class dealing with referrals - -ivan@sisd.com 98-feb-23 - -pod ivan@sisd.com 98-sep-21 - -=cut - -1; - diff --git a/site_perl/part_svc.pm b/site_perl/part_svc.pm deleted file mode 100644 index 0fd8ee4..0000000 --- a/site_perl/part_svc.pm +++ /dev/null @@ -1,199 +0,0 @@ -package FS::part_svc; - -use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(fields hfields); - -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(hfields fields); - -=head1 NAME - -FS::part_svc - Object methods for part_svc objects - -=head1 SYNOPSIS - - use FS::part_svc; - - $record = create FS::part_referral \%hash - $record = create FS::part_referral { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::part_svc represents a service definition. FS::part_svc inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item svcpart - primary key (assigned automatically for new service definitions) - -=item svc - text name of this service definition - -=item svcdb - table used for this service. See L<FS::svc_acct>, -L<FS::svc_domain>, and L<FS::svc_acct_sm>, among others. - -=item I<svcdb>__I<field> - Default or fixed value for I<field> in I<svcdb>. - -=item I<svcdb>__I<field>_flag - defines I<svcdb>__I<field> action: null, `D' for default, or `F' for fixed - -=back - -=head1 METHODS - -=over 4 - -=item create 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); -} - -=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. - -=cut - -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; -} - -=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 part_svc record!" unless $old->table eq "part_svc"; - return "Can't change svcpart!" - unless $old->getfield('svcpart') eq $new->getfield('svcpart'); - return "Can't change svcdb!" - unless $old->getfield('svcdb') eq $new->getfield('svcdb'); - $new->check or - $new->rep($old); -} - -=item check - -Checks all fields to make sure this is a valid service definition. If there is -an error, returns the error, otherwise returns false. Called by the insert -and replace methods. - -=cut - -sub check { - my($self)=@_; - return "Not a part_svc record!" unless $self->table eq "part_svc"; - my($recref) = $self->hashref; - - my($error); - return $error if $error= - $self->ut_numbern('svcpart') - || $self->ut_text('svc') - || $self->ut_alpha('svcdb') - ; - - my(@fields) = eval { fields($recref->{svcdb}) }; #might die - return "Unknown svcdb!" unless @fields; - - my($svcdb); - foreach $svcdb ( qw( - svc_acct svc_acct_sm svc_charge svc_domain svc_wo - ) ) { - my(@rows)=map { /^${svcdb}__(.*)$/; $1 } - grep ! /_flag$/, - grep /^${svcdb}__/, - fields('part_svc'); - my($row); - foreach $row (@rows) { - unless ( $svcdb eq $recref->{svcdb} ) { - $recref->{$svcdb.'__'.$row}=''; - $recref->{$svcdb.'__'.$row.'_flag'}=''; - next; - } - $recref->{$svcdb.'__'.$row.'_flag'} =~ /^([DF]?)$/ - or return "Illegal flag for $svcdb $row"; - $recref->{$svcdb.'__'.$row.'_flag'} = $1; - -# $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); - - } - } - - ''; #no error -} - -=back - -=head1 BUGS - -It doesn't properly override FS::Record yet. - -Delete is unimplemented. - -=head1 SEE ALSO - -L<FS::Record>, L<FS::part_pkg>, L<FS::pkg_svc>, L<FS::cust_svc>, -L<FS::svc_acct>, L<FS::svc_acct_sm>, L<FS::svc_domain>, schema.html from the -base documentation. - -=head1 HISTORY - -ivan@sisd.com 97-nov-14 - -data checking/untainting calls into FS::Record added -ivan@sisd.com 97-dec-6 - -pod ivan@sisd.com 98-sep-21 - -=cut - -1; - diff --git a/site_perl/pkg_svc.pm b/site_perl/pkg_svc.pm deleted file mode 100644 index 517125c..0000000 --- a/site_perl/pkg_svc.pm +++ /dev/null @@ -1,168 +0,0 @@ -package FS::pkg_svc; - -use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(fields hfields qsearchs); - -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(hfields); - -=head1 NAME - -FS::pkg_svc - Object methods for pkg_svc records - -=head1 SYNOPSIS - - use FS::pkg_svc; - - $record = create FS::pkg_svc \%hash; - $record = create FS::pkg_svc { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::pkg_svc record links a billing item definition (see L<FS::part_pkg>) to -a service definition (see L<FS::part_svc>). FS::pkg_svc inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item pkgpart - Billing item definition (see L<FS::part_pkg>) - -=item svcpart - Service definition (see L<FS::part_svc>) - -=item quantity - Quantity of this service definition that this billing item -definition includes - -=back - -=head1 METHODS - -=over 4 - -=item create 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); - -} - -=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 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); -} - -=item check - -Checks all fields to make sure this is a valid record. If there is an error, -returns the error, otherwise returns false. Called by the insert and replace -methods. - -=cut - -sub check { - my($self)=@_; - return "Not a pkg_svc record!" unless $self->table eq "pkg_svc"; - my($recref) = $self->hashref; - - my($error); - return $error if $error = - $self->ut_number('pkgpart') - || $self->ut_number('svcpart') - || $self->ut_number('quantity') - ; - - return "Unknown pkgpart!" - unless qsearchs('part_pkg',{'pkgpart'=> $self->getfield('pkgpart')}); - - return "Unknown svcpart!" - unless qsearchs('part_svc',{'svcpart'=> $self->getfield('svcpart')}); - - ''; #no error -} - -=back - -=head1 BUGS - -It doesn't properly override FS::Record yet. - -=head1 SEE ALSO - -L<FS::Record>, L<FS::part_pkg>, L<FS::part_svc>, schema.html from the base -documentation. - -=head1 HISTORY - -ivan@voicenet.com 97-jul-1 - -added hfields -ivan@sisd.com 97-nov-13 - -pod ivan@sisd.com 98-sep-22 - -=cut - -1; - diff --git a/site_perl/svc_acct.pm b/site_perl/svc_acct.pm deleted file mode 100644 index a43af6b..0000000 --- a/site_perl/svc_acct.pm +++ /dev/null @@ -1,557 +0,0 @@ -package FS::svc_acct; - -use strict; -use vars qw(@ISA @EXPORT_OK $nossh_hack $conf $dir_prefix @shells - $shellmachine @saltset @pw_set); -use Exporter; -use FS::Conf; -use FS::Record qw(fields qsearchs); -use FS::SSH qw(ssh); -use FS::cust_svc; - -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); - -$conf = new FS::Conf; -$dir_prefix = $conf->config('home'); -@shells = $conf->config('shells'); -$shellmachine = $conf->config('shellmachine'); - -@saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' ); -@pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' ); - -#not needed in 5.004 #srand($$|time); - -=head1 NAME - -FS::svc_acct - Object methods for svc_acct records - -=head1 SYNOPSIS - - use FS::svc_acct; - - $record = create FS::svc_acct \%hash; - $record = create FS::svc_acct { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - - $error = $record->suspend; - - $error = $record->unsuspend; - - $error = $record->cancel; - -=head1 DESCRIPTION - -An FS::svc_acct object represents an account. FS::svc_acct inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item svcnum - primary key (assigned automatcially for new accounts) - -=item username - -=item _password - generated if blank - -=item popnum - Point of presence (see L<FS::svc_acct_pop>) - -=item uid - -=item gid - -=item finger - GECOS - -=item dir - set automatically if blank (and uid is not) - -=item shell - -=item quota - (unimplementd) - -=item slipip - IP address - -=item radius_I<Radius_Attribute> - I<Radius-Attribute> - -=back - -=head1 METHODS - -=over 4 - -=item create 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); - -} - -=item insert - -Adds this account to the database. If there is an error, returns the error, -otherwise returns false. - -The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be -defined. An FS::cust_svc record will be created and inserted. - -If the configuration value (see L<FS::Conf>) shellmachine exists, and the -username, uid, and dir fields are defined, the command - - useradd -d $dir -m -s $shell -u $uid $username - -is executed on shellmachine via ssh. This behaviour can be surpressed by -setting $FS::svc_acct::nossh_hack true. - -=cut - -sub insert { - my($self)=@_; - my($error); - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - - $error=$self->check; - return $error if $error; - - return "Username ". $self->username. " in use" - if qsearchs('svc_acct',{'username'=> $self->username } ); - - my($part_svc) = qsearchs('part_svc',{ 'svcpart' => $self->svcpart }); - return "Unkonwn svcpart" unless $part_svc; - return "uid in use" - if $part_svc->svc_acct__uid_flag ne 'F' - && qsearchs('svc_acct',{'uid'=> $self->uid } ) - && $self->username !~ /^(hyla)?fax$/ - ; - - 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; - } - - my($username,$uid,$dir,$shell) = ( - $self->username, - $self->uid, - $self->dir, - $self->shell, - ); - if ( $username - && $uid - && $dir - && $shellmachine - && ! $nossh_hack ) { - #one way - ssh("root\@$shellmachine", - "useradd -d $dir -m -s $shell -u $uid $username" - ); - #another way - #ssh("root\@$shellmachine","/bin/mkdir $dir; /bin/chmod 711 $dir; ". - # "/bin/cp -p /etc/skel/.* $dir 2>/dev/null; ". - # "/bin/cp -pR /etc/skel/Maildir $dir 2>/dev/null; ". - # "/bin/chown -R $uid $dir") unless $nossh_hack; - } - - ''; #no error -} - -=item delete - -Deletes this account from the database. If there is an error, returns the -error, otherwise returns false. - -The corresponding FS::cust_svc record will be deleted as well. - -If the configuration value (see L<FS::Conf>) shellmachine exists, the command: - - userdel $username - -is executed on shellmachine via ssh. This behaviour can be surpressed by -setting $FS::svc_acct::nossh_hack true. - -=cut - -sub delete { - my($self)=@_; - my($error); - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - - 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; - - my($username) = $self->getfield('username'); - if ( $username && $shellmachine && ! $nossh_hack ) { - ssh("root\@$shellmachine","userdel $username"); - } - - ''; -} - -=item replace OLD_RECORD - -Replaces OLD_RECORD with this one in the database. If there is an error, -returns the error, otherwise returns false. - -If the configuration value (see L<FS::Conf>) shellmachine exists, and the -dir field has changed, the command: - - [ -d $old_dir ] && ( - chmod u+t $old_dir; - umask 022; - mkdir $new_dir; - cd $old_dir; - find . -depth -print | cpio -pdm $new_dir; - chmod u-t $new_dir; - chown -R $uid.$gid $new_dir; - rm -rf $old_dir - ) - -is executed on shellmachine via ssh. This behaviour can be surpressed by -setting $FS::svc_acct::nossh_hack true. - -=cut - -sub replace { - my($new,$old)=@_; - 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'); - - return "Username in use" - if $old->getfield('username') ne $new->getfield('username') && - qsearchs('svc_acct',{'username'=> $new->getfield('username') } ); - - return "Can't change uid!" - if $old->getfield('uid') ne $new->getfield('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; - - 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; - - my($old_dir,$new_dir)=( $old->getfield('dir'),$new->getfield('dir') ); - my($uid,$gid)=( $new->getfield('uid'), $new->getfield('gid') ); - if ( $old_dir - && $new_dir - && $old_dir ne $new_dir - && ! $nossh_hack - ) { - ssh("root\@$shellmachine","[ -d $old_dir ] && ". - "( chmod u+t $old_dir; ". #turn off qmail delivery - "umask 022; mkdir $new_dir; cd $old_dir; ". - "find . -depth -print | cpio -pdm $new_dir; ". - "chmod u-t $new_dir; chown -R $uid.$gid $new_dir; ". - "rm -rf $old_dir". - ")" - ); - } - - ''; #no error -} - -=item suspend - -Suspends this account by prefixing *SUSPENDED* to the password. If there is an -error, returns the error, otherwise returns false. - -Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>). - -=cut - -sub suspend { - my($old) = @_; - my(%hash) = $old->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 :) - } else { - ''; #no error (already suspended) - } - -} - -=item unsuspend - -Unsuspends this account by removing *SUSPENDED* from the password. If there is -an error, returns the error, otherwise returns false. - -Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>). - -=cut - -sub unsuspend { - my($old) = @_; - my(%hash) = $old->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 :) - } else { - ''; #no error (already unsuspended) - } -} - -=item cancel - -Just returns false (no error) for now. - -Called by the cancel method of FS::cust_pkg (see L<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, -returns the error, otherwise returns false. Called by the insert and replace -methods. - -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; - - #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') ) { - if ( $part_svc->getfield('svc_acct__'. $field. '_flag') eq 'F' ) { - $self->setfield($field,$part_svc->getfield('svc_acct__'. $field) ); - } - } - - my($ulen)=$self->dbdef_table->column('username')->length; - $recref->{username} =~ /^([a-z0-9_\-]{2,$ulen})$/ - or return "Illegal username"; - $recref->{username} = $1; - $recref->{username} =~ /[a-z]/ or return "Illegal username"; - - $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum"; - $recref->{popnum} = $1; - return "Unkonwn popnum" unless - ! $recref->{popnum} || - qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } ); - - unless ( $part_svc->getfield('svc_acct__uid_flag') eq 'F' ) { - - $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid"; - $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1; - - $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid"; - $recref->{gid} = $1 eq '' ? $recref->{uid} : $1; - #not all systems use gid=uid - #you can set a fixed gid in part_svc - - return "Only root can have uid 0" - if $recref->{uid} == 0 && $recref->{username} ne 'root'; - - my($error); - return $error if $error=$self->ut_textn('finger'); - - $recref->{dir} =~ /^([\/\w\-]*)$/ - or return "Illegal directory"; - $recref->{dir} = $1 || - $dir_prefix . '/' . $recref->{username} - #$dir_prefix . '/' . substr($recref->{username},0,1). '/' . $recref->{username} - ; - - unless ( $recref->{username} eq 'sync' ) { - my($shell); - if ( $shell = (grep $_ eq $recref->{shell}, @shells)[0] ) { - $recref->{shell} = $shell; - } else { - return "Illegal shell ". $self->shell; - } - } else { - $recref->{shell} = '/bin/sync'; - } - - $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota (unimplemented)"; - $recref->{quota} = $1; - - } else { - $recref->{gid} ne '' ? - return "Can't have gid without uid" : ( $recref->{gid}='' ); - $recref->{finger} ne '' ? - return "Can't have finger-name without uid" : ( $recref->{finger}='' ); - $recref->{dir} ne '' ? - return "Can't have directory without uid" : ( $recref->{dir}='' ); - $recref->{shell} ne '' ? - return "Can't have shell without uid" : ( $recref->{shell}='' ); - $recref->{quota} ne '' ? - return "Can't have quota without uid" : ( $recref->{quota}='' ); - } - - unless ( $part_svc->getfield('svc_acct__slipip_flag') eq 'F' ) { - unless ( $recref->{slipip} eq '0e0' ) { - $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/ - or return "Illegal slipip". $self->slipip; - $recref->{slipip} = $1; - } else { - $recref->{slipip} = '0e0'; - } - - } - - #arbitrary RADIUS stuff; allow ut_textn for now - foreach ( grep /^radius_/, fields('svc_acct') ) { - $self->ut_textn($_); - } - - #generate a password if it is blank - $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) ) - unless ( $recref->{_password} ); - - #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) { - if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,8})$/ ) { - $recref->{_password} = $1.$3; - #uncomment this to encrypt password immediately upon entry, or run - #bin/crypt_pw in cron to give new users a window during which their - #password is available to techs, for faxing, etc. (also be aware of - #radius issues!) - #$recref->{password} = $1. - # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))] - #; - } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/]{13,24})$/ ) { - $recref->{_password} = $1.$3; - } elsif ( $recref->{_password} eq '*' ) { - $recref->{_password} = '*'; - } else { - return "Illegal password"; - } - - ''; #no error -} - -=back - -=head1 BUGS - -It doesn't properly override FS::Record yet. - -The remote commands should be configurable. - -The create method should set defaults from part_svc (like the check method -sets fixed values). - -=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. - -=head1 HISTORY - -ivan@voicenet.com 97-jul-16 - 21 - -rewrite (among other things, now know about part_svc) ivan@sisd.com 98-mar-8 - -Changed 'password' to '_password' because Pg6.3 reserves the password word - bmccane@maxbaud.net 98-apr-3 - -username length and shell no longer hardcoded ivan@sisd.com 98-jun-28 - -eww but needed: ignore uid duplicates for 'fax' and 'hylafax' -ivan@sisd.com 98-jun-29 - -$nossh_hack ivan@sisd.com 98-jul-13 - -protections against UID/GID of 0 for incorrectly-setup RDBMSs (also -in bin/svc_acct.export) ivan@sisd.com 98-jul-13 - -arbitrary radius attributes ivan@sisd.com 98-aug-13 - -/var/spool/freeside/conf/shellmachine ivan@sisd.com 98-aug-13 - -pod and FS::conf ivan@sisd.com 98-sep-22 - -=cut - -1; - diff --git a/site_perl/svc_acct_pop.pm b/site_perl/svc_acct_pop.pm deleted file mode 100644 index a6f801f..0000000 --- a/site_perl/svc_acct_pop.pm +++ /dev/null @@ -1,163 +0,0 @@ -package FS::svc_acct_pop; - -use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(fields qsearchs); - -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); - -=head1 NAME - -FS::svc_acct_pop - Object methods for svc_acct_pop records - -=head1 SYNOPSIS - - use FS::svc_acct_pop; - - $record = create FS::svc_acct_pop \%hash; - $record = create FS::svc_acct_pop { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::svc_acct object represents an point of presence. FS::svc_acct_pop -inherits from FS::Record. The following fields are currently supported: - -=over 4 - -=item popnum - primary key (assigned automatically for new accounts) - -=item city - -=item state - -=item ac - area code - -=item exch - exchange - -=back - -=head1 METHODS - -=over 4 - -=item create 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); -} - -=item insert - -Adds this point of presence to the databaes. 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; -} - -=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 -an error, returns the error, otherwise returns false. Called by the insert -and replace methods. - -=cut - -sub check { - my($self)=@_; - return "Not a svc_acct_pop record!" unless $self->table eq "svc_acct_pop"; - - 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 - -It doesn't properly override FS::Record yet. - -It should be renamed to part_pop. - -=head1 SEE ALSO - -L<FS::Record>, L<svc_acct>, schema.html from the base documentation. - -=head1 HISTORY - -Class dealing with pops - -ivan@sisd.com 98-mar-8 - -pod ivan@sisd.com 98-sep-23 - -=cut - -1; - diff --git a/site_perl/svc_acct_sm.pm b/site_perl/svc_acct_sm.pm deleted file mode 100644 index c87ed2c..0000000 --- a/site_perl/svc_acct_sm.pm +++ /dev/null @@ -1,350 +0,0 @@ -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 FS::cust_svc; -use FS::SSH qw(ssh); -use FS::Conf; - -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); - -$conf = new FS::Conf; - -$shellmachine = $conf->exists('qmailmachines') - ? $conf->config('shellmachine') - : ''; - -=head1 NAME - -FS::svc_acct_sm - Object methods for svc_acct_sm records - -=head1 SYNOPSIS - - use FS::svc_acct_sm; - - $record = create FS::svc_acct_sm \%hash; - $record = create FS::svc_acct_sm { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - - $error = $record->suspend; - - $error = $record->unsuspend; - - $error = $record->cancel; - -=head1 DESCRIPTION - -An FS::svc_acct object represents a virtual mail alias. FS::svc_acct inherits -from FS::Record. The following fields are currently supported: - -=over 4 - -=item svcnum - primary key (assigned automatcially for new accounts) - -=item domsvc - svcnum of the virtual domain (see L<FS::svc_domain>) - -=item domuid - uid of the target account (see L<FS::svc_acct>) - -=item domuser - virtual username - -=back - -=head1 METHODS - -=over 4 - -=item create 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); - -} - -=item insert - -Adds this virtual mail alias to the database. If there is an error, returns -the error, otherwise returns false. - -The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be -defined. An FS::cust_svc record will be created and inserted. - -If the configuration values (see L<FS::Conf>) shellmachine and qmailmachines -exist, and domuser is `*' (meaning a catch-all mailbox), the command: - - [ -e $dir/.qmail-$qdomain-default ] || { - touch $dir/.qmail-$qdomain-default; - chown $uid:$gid $dir/.qmail-$qdomain-default; - } - -is executed on shellmachine via ssh (see L<dot-qmail/"EXTENSION ADDRESSES">). -This behaviour can be surpressed by setting $FS::svc_acct_sm::nossh_hack true. - -=cut - -sub insert { - my($self)=@_; - my($error); - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - - $error=$self->check; - return $error if $error; - - return "Domain username (domuser) in use for this domain (domsvc)" - if qsearchs('svc_acct_sm',{ 'domuser'=> $self->domuser, - 'domsvc' => $self->domsvc, - } ); - - return "First domain username (domuser) for domain (domsvc) must be " . - qq='*' (catch-all)!= - if $self->domuser ne '*' && - ! qsearch('svc_acct_sm',{ 'domsvc' => $self->domsvc } ); - - 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; - } - - 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($qdomain)=$domain; - $qdomain =~ s/\./:/g; #see manpage for 'dot-qmail': EXTENSION ADDRESSES - ssh("root\@$shellmachine","[ -e $dir/.qmail-$qdomain-default ] || { touch $dir/.qmail-$qdomain-default; chown $uid:$gid $dir/.qmail-$qdomain-default; }") - if ( ! $nossh_hack && $shellmachine && $dir && $self->domuser eq '*' ); - - ''; #no error - -} - -=item delete - -Deletes this virtual mail alias from the database. If there is an error, -returns the error, otherwise returns false. - -The corresponding FS::cust_svc record will be deleted as well. - -=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, -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'); - - return "Domain username (domuser) in use for this domain (domsvc)" - if ( $old->domuser ne $new->domuser - || $old->domsvc ne $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; - - ''; #no error -} - -=item suspend - -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 -an error, returns the error, otherwise returns false. Called by the insert and -replace methods. - -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; - - $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) ); - } - } - - $recref->{domuser} =~ /^(\*|[a-z0-9_\-]{2,32})$/ - or return "Illegal domain username (domuser)"; - $recref->{domuser} = $1; - - $recref->{domsvc} =~ /^(\d+)$/ or return "Illegal domsvc"; - $recref->{domsvc} = $1; - my($svc_domain); - return "Unknown domsvc" unless - $svc_domain=qsearchs('svc_domain',{'svcnum'=> $recref->{domsvc} } ); - - $recref->{domuid} =~ /^(\d+)$/ or return "Illegal uid"; - $recref->{domuid} = $1; - my($svc_acct); - return "Unknown uid" unless - $svc_acct=qsearchs('svc_acct',{'uid'=> $recref->{domuid} } ); - - ''; #no error -} - -=back - -=head1 BUGS - -It doesn't properly override FS::Record yet. - -The remote commands should be configurable. - -=head1 SEE ALSO - -L<FS::Record>, L<FS::Conf>, L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, -L<FS::svc_acct>, L<FS::svc_domain>, L<FS::SSH>, L<ssh>, L<dot-qmail>, -schema.html from the base documentation. - -=head1 HISTORY - -ivan@voicenet.com 97-jul-16 - 21 - -rewrite ivan@sisd.com 98-mar-10 - -s/qsearchs/qsearch/ to eliminate warning ivan@sisd.com 98-apr-19 - -uses conf/shellmachine and has an nossh_hack ivan@sisd.com 98-jul-14 - -s/\./:/g in .qmail-domain:com ivan@sisd.com 98-aug-13 - -pod, FS::Conf, moved .qmail file from check to insert 98-sep-23 - -=cut - -1; - diff --git a/site_perl/svc_domain.pm b/site_perl/svc_domain.pm deleted file mode 100644 index 1ddd5b2..0000000 --- a/site_perl/svc_domain.pm +++ /dev/null @@ -1,539 +0,0 @@ -package FS::svc_domain; - -use strict; -use vars qw(@ISA @EXPORT_OK $whois_hack $conf $mydomain $smtpmachine); -use Exporter; -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; - -=head1 NAME - -FS::svc_domain - Object methods for svc_domain records - -=head1 SYNOPSIS - - use FS::svc_domain; - - $record = create FS::svc_domain \%hash; - $record = create FS::svc_domain { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - - $error = $record->suspend; - - $error = $record->unsuspend; - - $error = $record->cancel; - -=head1 DESCRIPTION - -An FS::svc_domain object represents a domain. FS::svc_domain inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item svcnum - primary key (assigned automatically for new accounts) - -=item domain - -=back - -=head1 METHODS - -=over 4 - -=item create 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); - -} - -=item insert - -Adds this domain to the database. If there is an error, returns the error, -otherwise returns false. - -The additional fields I<pkgnum> and I<svcpart> (see L<FS::cust_svc>) should be -defined. An FS::cust_svc record will be created and inserted. - -The additional field I<action> should be set to I<N> for new domains or I<M> -for transfers. - -A registration or transfer email will be submitted unless -$FS::svc_domain::whois_hack is true. - -=cut - -sub insert { - my($self)=@_; - my($error); - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - - $error=$self->check; - return $error if $error; - - return "Domain in use (here)" - if qsearchs('svc_domain',{'domain'=> $self->domain } ); - - 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; - } - - $self->submit_internic unless $whois_hack; - - ''; #no error -} - -=item delete - -Deletes this domain from the database. If there is an error, returns the -error, otherwise returns false. - -The corresponding FS::cust_svc record will be deleted as well. - -=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, -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'); - - 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; - - ''; - -} - -=item suspend - -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, -returns the error, otherwise returns false. Called by the insert and replace -methods. - -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; - } 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) ); - } - } - - unless ( $whois_hack ) { - unless ( $self->email ) { #find out an email address - my(@svc_acct); - foreach ( qsearch('cust_svc',{'pkgnum'=>$pkgnum}) ) { - my($svc_acct)=qsearchs('svc_acct',{'svcnum'=>$_->svcnum}); - push @svc_acct, $svc_acct if $svc_acct; - } - - if ( scalar(@svc_acct) == 0 ) { - return "Must order an account first"; - } elsif ( scalar(@svc_acct) > 1 ) { - return "More than one account in package ". $pkgnum. ": specify admin contact email"; - } else { - $self->email($svc_acct[0]->username. '@'. $mydomain); - } - } - } - - #if ( $recref->{domain} =~ /^([\w\-\.]{1,22})\.(com|net|org|edu)$/ ) { - if ( $recref->{domain} =~ /^([\w\-]{1,22})\.(com|net|org|edu)$/ ) { - $recref->{domain} = "$1.$2"; - # hmmmmmmmm. - } elsif ( $whois_hack && $recref->{domain} =~ /^([\w\-\.]+)$/ ) { - $recref->{domain} = $1; - } else { - return "Illegal domain ". $recref->{domain}. - " (or unknown registry - try \$whois_hack)"; - } - - $recref->{action} =~ /^(M|N)$/ or return "Illegal action"; - $recref->{action} = $1; - - $self->ut_textn('purpose'); - -} - -=item _whois - -Executes the command: - - whois do $domain - -and returns the output. - -(Always returns I<No match for domian "$domain".> if -$FS::svc_domain::whois_hack is set true.) - -=cut - -sub _whois { - my($self)=@_; - my($domain)=$self->domain; - return ( "No match for domain \"$domain\"." ) if $whois_hack; - open(WHOIS,"whois do $domain |"); - return <WHOIS>; -} - -=item submit_internic - -Submits a registration email for this domain. - -=cut - -sub submit_internic { - my($self)=@_; - - my($cust_pkg)=qsearchs('cust_pkg',{'pkgnum'=>$self->pkgnum}); - return unless $cust_pkg; - my($cust_main)=qsearchs('cust_main',{'custnum'=>$cust_pkg->custnum}); - return unless $cust_main; - - my(%subs)=( - 'action' => $self->action, - 'purpose' => $self->purpose, - 'domain' => $self->domain, - 'company' => $cust_main->company - || $cust_main->getfield('first'). ' '. - $cust_main->getfield('last') - , - 'city' => $cust_main->city, - 'state' => $cust_main->state, - 'zip' => $cust_main->zip, - 'country' => $cust_main->country, - 'last' => $cust_main->getfield('last'), - 'first' => $cust_main->getfield('first'), - 'daytime' => $cust_main->daytime, - 'fax' => $cust_main->fax, - 'email' => $self->email, - 'tech_contact' => $tech_contact, - 'primary' => shift @nameservers, - 'primary_ip' => shift @nameserver_ips, - ); - - #yuck - my(@xtemplate)=@template; - my(@body); - my($line); - OLOOP: while ( defined($line = shift @xtemplate) ) { - - if ( $line =~ /^###LOOP###$/ ) { - my(@buffer); - LOADBUF: while ( defined($line = shift @xtemplate) ) { - last LOADBUF if ( $line =~ /^###ENDLOOP###$/ ); - push @buffer, $line; - } - my(%lubs)=( - 'address' => $cust_main->address2 - ? [ $cust_main->address1, $cust_main->address2 ] - : [ $cust_main->address1 ] - , - 'secondary' => [ @nameservers ], - 'secondary_ip' => [ @nameserver_ips ], - ); - LOOP: while (1) { - my(@xbuffer)=@buffer; - SUBLOOP: while ( defined($line = shift @xbuffer) ) { - if ( $line =~ /###(\w+)###/ ) { - #last LOOP unless my($lub)=shift@{$lubs{$1}}; - next OLOOP unless my $lub = shift @{$lubs{$1}}; - $line =~ s/###(\w+)###/$lub/e; - redo SUBLOOP; - } else { - push @body, $line; - } - } #SUBLOOP - } #LOOP - - } - - if ( $line =~ /###(\w+)###/ ) { - #$line =~ s/###(\w+)###/$subs{$1}/eg; - $line =~ s/###(\w+)###/$subs{$1}/e; - redo OLOOP; - } else { - push @body, $line; - } - - } #OLOOP - - my($subject); - if ( $self->action eq "M" ) { - $subject = "MODIFY DOMAIN ". $self->domain; - } elsif ($self->action eq "N" ) { - $subject = "NEW DOMAIN ". $self->domain; - } else { - croak "submit_internic called with action ". $self->action; - } - - $ENV{SMTPHOSTS}=$smtpmachine; - $ENV{MAILADDRESS}=$from; - my($header)=Mail::Header->new( [ - "From: $from", - "To: $to", - "Sender: $from", - "Reply-To: $from", - "Date: ". time2str("%a, %d %b %Y %X %z",time), - "Subject: $subject", - ] ); - - my($msg)=Mail::Internet->new( - 'Header' => $header, - 'Body' => \@body, - ); - - $msg->smtpsend or die "Can't send registration email"; #die? warn? - -} - -=back - -=head1 BUGS - -It doesn't properly override FS::Record yet. - -All BIND/DNS fields should be included (and exported). - -All registries should be supported. - -Not all configuration access is through FS::Conf! - -Should change action to a real field. - -=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. - -=head1 HISTORY - -ivan@voicenet.com 97-jul-21 - -rewrite ivan@sisd.com 98-mar-10 - -add internic bits ivan@sisd.com 98-mar-14 - -Changed 'day' to 'daytime' because Pg6.3 reserves the day word - bmccane@maxbaud.net 98-apr-3 - -/var/spool/freeside/conf/registries/internic/, Mail::Internet, etc. -ivan@sisd.com 98-jul-17-19 - -pod, some FS::Conf (not complete) ivan@sisd.com 98-sep-23 - -=cut - -1; - - diff --git a/site_perl/table_template-svc.pm b/site_perl/table_template-svc.pm deleted file mode 100644 index a8cbaed..0000000 --- a/site_perl/table_template-svc.pm +++ /dev/null @@ -1,107 +0,0 @@ -#!/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); - -@FS::svc_table::ISA = qw(FS::Record Exporter); - -# Usage: $record = create FS::svc_table ( \%hash ); -# $record = create FS::svc_table ( { field=>value, ... } ); -sub create { - my($proto,$hashref)=@_; - - my($field); - foreach $field (fields('svc_table')) { - $hashref->{$field}='' unless defined $hashref->{$field}; - } - - $proto->new('svc_table',$hashref); - -} - -# Usage: $error = $record -> insert; -sub insert { - my($self)=@_; - my($error); - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - - $error=$self->check; - return $error if $error; - - $error = $self->add; - return $error if $error; - - ''; #no error -} - -# Usage: $error = $record -> delete; -sub delete { - my($self)=@_; - my($error); - - $error = $self->del; - 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'); - - $error=$new->check; - return $error if $error; - - $error = $new->rep($old); - return $error if $error; - - ''; #no error -} - -# Usage: $error = $record -> suspend; -sub suspend { - ''; #no error (stub) -} - -# Usage: $error = $record -> unsuspend; -sub unsuspend { - ''; #no error (stub) -} - -# Usage: $error = $record -> cancel; -sub cancel { - ''; #no error (stub) -} - -# Usage: $error = $record -> check; -sub check { - my($self)=@_; - return "Not a svc_table record!" unless $self->table eq "svc_table"; - my($recref) = $self->hashref; - - $recref->{svcnum} =~ /^(\d+)$/ or return "Illegal svcnum"; - $recref->{svcnum} = $1; - return "Unknown svcnum" unless - qsearchs('cust_svc',{'svcnum'=> $recref->{svcnum} } ); - - #DATA CHECKS GO HERE! - - ''; #no error -} - -1; - diff --git a/site_perl/table_template-unique.pm b/site_perl/table_template-unique.pm deleted file mode 100644 index 32b7e69..0000000 --- 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 deleted file mode 100644 index cef2d92..0000000 --- a/site_perl/table_template.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(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"; - - $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/type_pkgs.pm b/site_perl/type_pkgs.pm deleted file mode 100644 index a715796..0000000 --- a/site_perl/type_pkgs.pm +++ /dev/null @@ -1,150 +0,0 @@ -package FS::type_pkgs; - -use strict; -use vars qw(@ISA @EXPORT_OK); -use Exporter; -use FS::Record qw(fields qsearchs); - -@ISA = qw(FS::Record Exporter); -@EXPORT_OK = qw(fields); - -=head1 NAME - -FS::type_pkgs - Object methods for type_pkgs records - -=head1 SYNOPSIS - - use FS::type_pkgs; - - $record = create FS::type_pkgs \%hash; - $record = create FS::type_pkgs { 'column' => 'value' }; - - $error = $record->insert; - - $error = $new_record->replace($old_record); - - $error = $record->delete; - - $error = $record->check; - -=head1 DESCRIPTION - -An FS::type_pkgs record links an agent type (see L<FS::agent_type>) to a -billing item definition (see L<FS::part_pkg>). FS::type_pkgs inherits from -FS::Record. The following fields are currently supported: - -=over 4 - -=item typenum - Agent type, see L<FS::agent_type> - -=item pkgpart - Billing item definition, see L<FS::part_pkg> - -=back - -=head1 METHODS - -=over 4 - -=item create 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); - -} - -=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, -returns the error, otherwise returns false. Called by the insert and replace -methods. - -=cut - -sub check { - my($self)=@_; - return "Not a type_pkgs record!" unless $self->table eq "type_pkgs"; - my($recref) = $self->hashref; - - $recref->{typenum} =~ /^(\d+)$/ or return "Illegal typenum"; - $recref->{typenum} = $1; - return "Unknown typenum" - unless qsearchs('agent_type',{'typenum'=>$recref->{typenum}}); - - $recref->{pkgpart} =~ /^(\d+)$/ or return "Illegal pkgpart"; - $recref->{pkgpart} = $1; - return "Unknown pkgpart" - unless qsearchs('part_pkg',{'pkgpart'=>$recref->{pkgpart}}); - - ''; #no error -} - -=back - -=head1 HISTORY - -Defines the relation between agent types and pkgparts -(Which pkgparts can the different [types of] agents sell?) - -ivan@sisd.com 97-nov-13 - -change to ut_ FS::Record, fixed bugs -ivan@sisd.com 97-dec-10 - -=cut - -1; - |