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