diff options
Diffstat (limited to 'FS')
47 files changed, 10309 insertions, 0 deletions
diff --git a/FS/Changes b/FS/Changes new file mode 100644 index 000000000..c94ef10f5 --- /dev/null +++ b/FS/Changes @@ -0,0 +1,5 @@ +Revision history for Perl extension FS. + +0.01 Wed Aug 4 00:13:45 1999 + - original version; created by h2xs 1.19 + diff --git a/FS/FS.pm b/FS/FS.pm new file mode 100644 index 000000000..ed61db4c8 --- /dev/null +++ b/FS/FS.pm @@ -0,0 +1,157 @@ +package FS; + +use strict; +use vars qw($VERSION); + +$VERSION = '0.01'; + +1; +__END__ + +=head1 NAME + +FS - Freeside Perl modules + +=head1 SYNOPSIS + +FS is the unofficial (i.e. non-CPAN) prefix for the Perl module portion of the +Freeside ISP billing software. This includes: + +=head2 Utility classes + +L<FS::Conf> - Freeside configuration values + +L<FS::UID> - User class (not yet OO) + +L<FS::CGI> - Non OO-subroutines for the web interface. This is +depriciated. Future development will be focused on the FS::UI user-interface +classes (see below). + +=head2 Database record classes + +L<FS::Record> - Database record base class + +L<FS::svc_acct_pop> - POP (Point of Presence, not Post +Office Protocol) class + +L<FS::part_referral> - Referral class + +L<FS::cust_main_county> - Locale (tax rate) class + +L<FS::svc_Common> - Service base class + +L<FS::svc_acct> - Account (shell, RADIUS, POP3) class + +L<FS::svc_domain> - Domain class + +L<FS::domain_record> - DNS zone entries + +L<FS::svc_acct_sm> - Vitual mail alias class + +L<FS::svc_www> - Web virtual host class. + +L<FS::part_svc> - Service definition class + +L<FS::part_pkg> - Package (billing item) definition class + +L<FS::pkg_svc> - Class linking package (billing item) +definitions (see L<FS::part_pkg>) with service definitions +(see L<FS::part_svc>) + +L<FS::agent> - Agent (reseller) class + +L<FS::agent_type> - Agent type class + +L<FS::type_pkgs> - Class linking agent types (see +L<FS::agent_type>) with package (billing item) definitions +(see L<FS::part_pkg>) + +L<FS::cust_svc> - Service class + +L<FS::cust_pkg> - Package (billing item) class + +L<FS::cust_main> - Customer class + +L<FS::cust_main_invoice> - Invoice destination +class + +L<FS::cust_bill> - Invoice class + +L<FS::cust_bill_pkg> - Invoice line item class + +L<FS::cust_pay> - Payment class + +L<FS::cust_credit> - Credit class + +L<FS::cust_refund> - Refund class + +L<FS::cust_pay_batch> - Credit card transaction queue class + +L<FS::prepay_credit> - Prepaid "calling card" credit class. + +L<FS::nas> - Network Access Server class + +L<FS::port> - NAS port class + +L<FS::session> - User login session class + +=head2 User Interface classes (under development; not yet usable) + +L<FS::UI::Base> - User-interface base class + +L<FS::UI::Gtk> - Gtk user-interface class + +L<FS::UI::CGI> - CGI (HTML) user-interface class + +L<FS::UI::agent> - agent table user-interface class + +=head2 Notes + +To quote perl(1), "If you're intending to read these straight through for the +first time, the suggested order will tend to reduce the number of forward +references." + +=head1 DESCRIPTION + +Freeside is a billing and administration package for Internet Service +Providers. + +The Freeside home page is at <http://www.sisd.com/freeside>. + +The main documentation is in htdocs/docs. + +=head1 VERSION + +$Id: FS.pm,v 1.5 2001-04-23 12:40:30 ivan Exp $ + +=head1 SUPPORT + +A mailing list for users and developers is available. Send a blank message to +<ivan-freeside-subscribe@sisd.com> to subscribe. + +Commercial support is available; see +<http://www.sisd.com/freeside/commercial.html>. + +=head1 AUTHOR + +Primarily Ivan Kohler <ivan@sisd.com>, with help from many kind folks. + +See the CREDITS file in the Freeside distribution for a (hopefully) complete +list and the individal files for details. + +=head1 SEE ALSO + +perl(1), main Freeside documentation in htdocs/docs/ + +=head1 BUGS + +The version number of the FS Perl extension differs from the version of the +Freeside distribution, which are both different from the CVS version tag for +each file, which appears under the VERSION heading. + +Those modules which would be useful separately should be pulled out, +renamed appropriately and uploaded to CPAN. So far: DBIx::DBSchema, Net::SSH +and Net::SCP... + +=cut + diff --git a/FS/FS/CGI.pm b/FS/FS/CGI.pm new file mode 100644 index 000000000..198477ce6 --- /dev/null +++ b/FS/FS/CGI.pm @@ -0,0 +1,218 @@ +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(@_); + if (exists $ENV{MOD_PERL}) { + eval { + use Apache; + Apache::exit(); + }; + } else { + 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->isa('Apache') ? $cgi->uri : $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> + +=cut + +1; + + diff --git a/FS/FS/CGIwrapper.pm b/FS/FS/CGIwrapper.pm new file mode 100644 index 000000000..863193e94 --- /dev/null +++ b/FS/FS/CGIwrapper.pm @@ -0,0 +1,17 @@ +package FS::CGIwrapper; + +use vars qw(@ISA); + +use CGI; + +@ISA = qw( CGI ); + +sub header { + my $self = shift; + $self->SUPER::header( + @_, + '-expires' => 'now', + '-pragma' => 'No-Cache', + '-cache-control' => 'No-Cache', + ); +} diff --git a/FS/FS/Conf.pm b/FS/FS/Conf.pm new file mode 100644 index 000000000..7c6105bdc --- /dev/null +++ b/FS/FS/Conf.pm @@ -0,0 +1,112 @@ +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. + +=cut + +1; diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm new file mode 100644 index 000000000..113e1a18d --- /dev/null +++ b/FS/FS/Record.pm @@ -0,0 +1,968 @@ +package FS::Record; + +use strict; +use vars qw($dbdef_file $dbdef $setup_hack $AUTOLOAD @ISA @EXPORT_OK $DEBUG); +use subs qw(reload_dbdef); +use Exporter; +use Carp qw(carp cluck croak confess); +use File::CounterFile; +use DBIx::DBSchema; +use FS::UID qw(dbh checkruid swapuid getotaker datasrc driver_name); + +@ISA = qw(Exporter); +@EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef); + +$DEBUG = 0; + +#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 ( driver_name =~ /^Pg$/i + && $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, SELECT, EXTRA_SQL + +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. + +###oops, argh, FS::Record::new only lets us create database fields. +#Normal behaviour if SELECT is not specified is `*', as in +#C<SELECT * FROM table WHERE ...>. However, there is an experimental new +#feature where you can specify SELECT - remember, the objects returned, +#although blessed into the appropriate `FS::TABLE' package, will only have the +#fields you specify. This might have unwanted results if you then go calling +#regular FS::TABLE methods +#on it. + +=cut + +sub qsearch { + my($table, $record, $select, $extra_sql ) = @_; + $select ||= '*'; + my $dbh = dbh; + + my @fields = grep exists($record->{$_}), fields($table); + + my $statement = "SELECT $select FROM $table"; + if ( @fields ) { + $statement .= ' WHERE '. join(' AND ', map { + if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) { + if ( driver_name =~ /^Pg$/i ) { + "$_ IS NULL"; + } else { + qq-( $_ IS NULL OR $_ = "" )-; + } + } else { + "$_ = ?"; + } + } @fields ); + } + $statement .= " $extra_sql" if defined($extra_sql); + + warn $statement if $DEBUG; + my $sth = $dbh->prepare($statement) + or croak "$dbh->errstr doing $statement"; + + $sth->execute( map $record->{$_}, + grep defined( $record->{$_} ) && $record->{$_} ne '', @fields + ) or croak $dbh->errstr; + $dbh->commit or croak $dbh->errstr if $FS::UID::AutoCommit; + + if ( eval 'scalar(@FS::'. $table. '::ISA);' ) { + if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) { + #derivied class didn't override new method, so this optimization is safe + map { + new( "FS::$table", { %{$_} } ) + } @{$sth->fetchall_arrayref( {} )}; + } else { + warn "untested code (class FS::$table uses custom new method)"; + map { + eval 'FS::'. $table. '->new( { %{$_} } )'; + } @{$sth->fetchall_arrayref( {} )}; + } + } else { + cluck "warning: FS::$table not loaded; returning FS::Record objects"; + map { + FS::Record->new( $table, { %{$_} } ); + } @{$sth->fetchall_arrayref( {} )}; + } + +} + +=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? + scalar(@result) ? ($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; + dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit; + + ''; +} + +=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 $_ = \"\" )" + ? ( driver_name =~ /^Pg$/i + ? "$_ 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"; + dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit; + + 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 $_ = \"\" )" + ? ( driver_name =~ /^Pg$/i + ? "$_ 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"; + dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit; + + ''; + +} + +=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<DBIx::DBSchema::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 [ COUNTRY ] + +Check/untaint phone numbers. May be null. If there is an error, returns +the error, otherwise returns false. + +Takes an optional two-letter ISO country code; without it or with unsupported +countries, ut_phonen simply calls ut_alphan. + +=cut + +sub ut_phonen { + my( $self, $field, $country ) = @_; + return $self->ut_alphan($field) unless defined $country; + my $phonen = $self->getfield($field); + if ( $phonen eq '' ) { + $self->setfield($field,''); + } elsif ( $country eq 'US' ) { + $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); + } else { + warn "don't know how to check phone numbers for country $country"; + return $self->ut_alphan($field); + } + ''; +} + +=item ut_ip COLUMN + +Check/untaint ip addresses. IPv4 only for now. + +=cut + +sub ut_ip { + my( $self, $field ) = @_; + $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/ + or return "Illegal (IP address) $field: ". $self->getfield($field); + for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; } + $self->setfield($field, "$1.$2.$3.$3"); + ''; +} + +=item ut_ipn COLUMN + +Check/untaint ip addresses. IPv4 only for now. May be null. + +=cut + +sub ut_ipn { + my( $self, $field ) = @_; + if ( $self->getfield($field) =~ /^()$/ ) { + $self->setfield($field,''); + ''; + } else { + $self->ut_ip($field); + } +} + +=item ut_domain COLUMN + +Check/untaint host and domain names. + +=cut + +sub ut_domain { + my( $self, $field ) = @_; + #$self->getfield($field) =~/^(\w+\.)*\w+$/ + $self->getfield($field) =~/^(\w+\.)*\w+$/ + or return "Illegal (domain) $field: ". $self->getfield($field); + $self->setfield($field,$1); + ''; +} + +=cut + +=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<DBIx::DBSchema::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<DBIx::DBSchema>), optionally from a +non-default filename. This command is executed at startup unless +I<$FS::Record::setup_hack> is true. Returns a DBIx::DBSchema object. + +=cut + +sub reload_dbdef { + my $file = shift || $dbdef_file; + $dbdef = load DBIx::DBSchema $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<FS::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 { return; } + +#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.14 2001-04-15 12:56:30 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 which 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) + +As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc, +or allow it to be set. Working around it is ugly any way around - DBI should +be fixed. (only affects RDBMS which return uppercase column names) + +=head1 SEE ALSO + +L<DBIx::DBSchema>, L<FS::UID>, L<DBI> + +Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan. + +=cut + +1; + diff --git a/FS/FS/UI/Base.pm b/FS/FS/UI/Base.pm new file mode 100644 index 000000000..bbeb9e171 --- /dev/null +++ b/FS/FS/UI/Base.pm @@ -0,0 +1,194 @@ +package FS::UI::Base; + +use strict; +use vars qw ( @ISA ); +use FS::Record qw( fields qsearch ); + +@ISA = ( $FS::UI::Base::_lock ); + +=head1 NAME + +FS::UI::Base - Base class for all user-interface objects + +=head1 SYNOPSIS + + use FS::UI::SomeInterface; + use FS::UI::some_table; + + $interface = new FS::UI::some_table; + + $error = $interface->browse; + $error = $interface->search; + $error = $interface->view; + $error = $interface->edit; + $error = $interface->process; + +=head1 DESCRIPTION + +An FS::UI::Base object represents a user interface object. FS::UI::Base +is intended as a base class for table-specfic classes to inherit from, i.e. +FS::UI::cust_main. The simplest case, which will provide a default UI for your +new table, is as follows: + + package FS::UI::table_name; + use vars qw ( @ISA ); + use FS::UI::Base; + @ISA = qw( FS::UI::Base ); + sub db_table { 'table_name'; } + +Currently available interfaces are: + FS::UI::Gtk, an X-Windows UI implemented using the Gtk+ toolkit + FS::UI::CGI, a web interface implemented using CGI.pm, etc. + +=head1 METHODS + +=over 4 + +=item new + +=cut + +=item browse + +=cut + +sub browse { + my $self = shift; + + my @fields = $self->list_fields; + + #begin browse-specific stuff + + $self->title( "Browse ". $self->db_names ) unless $self->title; + my @records = qsearch ( $self->db_table, {} ); + + #end browse-specific stuff + + $self->addwidget ( new FS::UI::_Text ( $self->db_description ) ); + + my @header = $self->list_header; + my @headerspan = $self->list_headerspan; + my %callback = $self->db_callback; + + my $columns; + + my $table = new FS::UI::_Tableborder ( + 'rows' => 1 + scalar(@records), + 'columns' => $columns || scalar(@fields), + ); + + my $c = 0; + foreach my $header ( @header ) { + my $headerspan = shift(@headerspan) || 1; + $table->attach( + 0, $c, new FS::UI::_Text ( $header ), 1, $headerspan + ); + $c += $headerspan; + } + + my $r = 1; + + foreach my $record ( @records ) { + $c = 0; + foreach my $field ( @fields ) { + my $value = $record->getfield($field); + my $widget; + if ( $callback{$field} ) { + $widget = &{ $callback{$field} }( $value, $record ); + } else { + $widget = new FS::UI::_Text ( $value ); + } + $table->attach( $r, $c++, $widget, 1, 1 ); + } + $r++; + } + + $self->addwidget( $table ); + + $self->activate; + +} + +=item title + +=cut + +sub title { + my $self = shift; + my $value = shift; + if ( defined($value) ) { + $self->{'title'} = $value; + } else { + $self->{'title'}; + } +} + +=item addwidget + +=cut + +sub addwidget { + my $self = shift; + my $widget = shift; + push @{ $self->{'Widgets'} }, $widget; +} + +#fallback methods + +sub db_description {} + +sub db_name {} + +sub db_names { + my $self = shift; + $self->db_name. 's'; +} + +sub list_fields { + my $self = shift; + fields( $self->db_table ); +} + +sub list_header { + my $self = shift; + $self->list_fields +} + +sub list_headerspan { + my $self = shift; + map 1, $self->list_header; +} + +sub db_callback {} + +=back + +=head1 VERSION + +$Id: Base.pm,v 1.1 1999-08-04 09:03:53 ivan Exp $ + +=head1 BUGS + +This documentation is incomplete. + +There should be some sort of per-(freeside)-user preferences and the ability +for specific FS::UI:: modules to put their own values there as well. + +=head1 SEE ALSO + +L<FS::UI::Gtk>, L<FS::UI::CGI> + +=head1 HISTORY + +$Log: Base.pm,v $ +Revision 1.1 1999-08-04 09:03:53 ivan +initial checkin of module files for proper perl installation + +Revision 1.1 1999/01/20 09:30:36 ivan +skeletal cross-UI UI code. + + +=cut + +1; + diff --git a/FS/FS/UI/CGI.pm b/FS/FS/UI/CGI.pm new file mode 100644 index 000000000..ae87d1375 --- /dev/null +++ b/FS/FS/UI/CGI.pm @@ -0,0 +1,239 @@ +package FS::UI::CGI; + +use strict; +use CGI; +#use CGI::Switch; #when FS::UID user and preference callback stuff is fixed +use CGI::Carp qw(fatalsToBrowser); +use HTML::Table; +use FS::UID qw(adminsuidsetup); +#use FS::Record qw( qsearch fields ); + +die "Can't initialize CGI interface; $FS::UI::Base::_lock used" + if $FS::UI::Base::_lock; +$FS::UI::Base::_lock = "FS::UI::CGI"; + +=head1 NAME + +FS::UI::CGI - Base class for CGI user-interface objects + +=head1 SYNOPSIS + + use FS::UI::CGI; + use FS::UI::some_table; + + $interface = new FS::UI::some_table; + + $error = $interface->browse; + $error = $interface->search; + $error = $interface->view; + $error = $interface->edit; + $error = $interface->process; + +=head1 DESCRIPTION + +An FS::UI::CGI object represents a CGI interface object. + +=head1 METHODS + +=over 4 + +=item new + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = { @_ }; + + $self->{'_cgi'} = new CGI; + $self->{'_user'} = $self->{'_cgi'}->remote_user; + $self->{'_dbh'} = FS::UID::adminsuidsetup $self->{'_user'}; + + bless ( $self, $class); +} + +sub activate { + my $self = shift; + print $self->_header, + join ( "<BR>", map $_->sprint, @{ $self->{'Widgets'} } ), + $self->_footer, + ; +} + +=item _header + +=cut + +sub _header { + my $self = shift; + my $cgi = $self->{'_cgi'}; + + $cgi->header( '-expires' => 'now' ), '<HTML>', + '<HEAD><TITLE>', $self->title, '</TITLE></HEAD>', + '<BODY BGCOLOR="#ffffff">', + '<FONT COLOR="#ff0000" SIZE=7>', $self->title, '</FONT><BR><BR>', + ; +} + +=item _footer + +=cut + +sub _footer { + "</BODY></HTML>"; +} + +=item interface + +Returns the string `CGI'. Useful for the author of a table-specific UI class +to conditionally specify certain behaviour. + +=cut + +sub interface { 'CGI'; } + +=back + +=cut + +package FS::UI::_Widget; + +use vars qw( $AUTOLOAD ); + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = { @_ }; + bless ( $self, $class ); +} + +sub AUTOLOAD { + my $self = shift; + my $value = shift; + my($field)=$AUTOLOAD; + $field =~ s/.*://; + if ( defined($value) ) { + $self->{$field} = $value; + } else { + $self->{$field}; + } +} + +package FS::UI::_Text; + +use vars qw ( @ISA ); + +@ISA = qw ( FS::UI::_Widget); + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + $self->{'_text'} = shift; + bless ( $self, $class ); +} + +sub sprint { + my $self = shift; + $self->{'_text'}; +} + +package FS::UI::_Link; + +use vars qw ( @ISA $BASE_URL ); + +@ISA = qw ( FS::UI::_Widget); +$BASE_URL = "http://rootwood.sisd.com/freeside"; + +sub sprint { + my $self = shift; + my $table = $self->{'table'}; + my $method = $self->{'method'}; + + # i will be cleaned up when we're done moving from the old webinterface! + my @arg = @{$self->{'arg'}}; + my $yuck = join( "&", @arg); + qq(<A HREF="$BASE_URL/$method/$table.cgi?$yuck">). $self->{'text'}. "<\A>"; +} + +package FS::UI::_Table; + +use vars qw ( @ISA ); + +@ISA = qw ( FS::UI::_Widget); + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class eq $proto ? { @_ } : $proto; + bless ( $self, $class ); + $self->{'_table'} = new HTML::Table ( $self->rows, $self->columns ); + $self; +} + +sub attach { + my $self = shift; + my ( $row, $column, $widget, $rowspan, $colspan ) = @_; + $self->{"_table"}->setCell( $row+1, $column+1, $widget->sprint ); + $self->{"_table"}->setCellRowSpan( $row+1, $column+1, $rowspan ) if $rowspan; + $self->{"_table"}->setCellColSpan( $row+1, $column+1, $colspan ) if $colspan; +} + +sub sprint { + my $self = shift; + $self->{'_table'}->getTable; +} + +package FS::UI::_Tableborder; + +use vars qw ( @ISA ); + +@ISA = qw ( FS::UI::_Table ); + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class eq $proto ? { @_ } : $proto; + bless ( $self, $class ); + $self->SUPER::new(@_); + $self->{'_table'}->setBorder; + $self; +} + +=head1 VERSION + +$Id: CGI.pm,v 1.1 1999-08-04 09:03:53 ivan Exp $ + +=head1 BUGS + +This documentation is incomplete. + +In _Tableborder, headers should be links that sort on their fields. + +_Link uses a constant $BASE_URL + +_Link passes the arguments as a manually-constructed GET string instead +of POSTing, for compatability while the web interface is upgraded. Once +this is done it should pass arguements properly (i.e. as a POST, 8-bit clean) + +Still some small bits of widget code same as FS::UI::Gtk. + +=head1 SEE ALSO + +L<FS::UI::Base> + +=head1 HISTORY + +$Log: CGI.pm,v $ +Revision 1.1 1999-08-04 09:03:53 ivan +initial checkin of module files for proper perl installation + +Revision 1.1 1999/01/20 09:30:36 ivan +skeletal cross-UI UI code. + + +=cut + +1; + diff --git a/FS/FS/UI/Gtk.pm b/FS/FS/UI/Gtk.pm new file mode 100644 index 000000000..507a29361 --- /dev/null +++ b/FS/FS/UI/Gtk.pm @@ -0,0 +1,224 @@ +package FS::UI::Gtk; + +use strict; +use Gtk; +use FS::UID qw(adminsuidsetup); + +die "Can't initialize Gtk interface; $FS::UI::Base::_lock used" + if $FS::UI::Base::_lock; +$FS::UI::Base::_lock = "FS::UI::Gtk"; + +=head1 NAME + +FS::UI::Gtk - Base class for Gtk user-interface objects + +=head1 SYNOPSIS + + use FS::UI::Gtk; + use FS::UI::some_table; + + $interface = new FS::UI::some_table; + + $error = $interface->browse; + $error = $interface->search; + $error = $interface->view; + $error = $interface->edit; + $error = $interface->process; + +=head1 DESCRIPTION + +An FS::UI::Gtk object represents a Gtk user interface object. + +=head1 METHODS + +=over 4 + +=item new + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = { @_ }; + + bless ( $self, $class ); + + $self->{'_user'} = 'ivan'; #Pop up login window? + $self->{'_dbh'} = FS::UID::adminsuidsetup $self->{'_user'}; + + + + $self; +} + +sub activate { + my $self = shift; + + my $vbox = new Gtk::VBox ( 0, 4 ); + + foreach my $widget ( @{ $self->{'Widgets'} } ) { + $widget->_gtk->show; + $vbox->pack_start ( $widget->_gtk, 1, 1, 4 ); + } + $vbox->show; + + my $window = new Gtk::Window "toplevel"; + $self->{'_gtk'} = $window; + $window->set_title( $self->title ); + $window->add ( $vbox ); + $window->show; + main Gtk; +} + +=item interface + +Returns the string `Gtk'. Useful for the author of a table-specific UI class +to conditionally specify certain behaviour. + +=cut + +sub interface { 'Gtk'; } + +=back + +=cut + +package FS::UI::_Widget; + +use vars qw( $AUTOLOAD ); + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = { @_ }; + bless ( $self, $class ); +} + +sub _gtk { + my $self = shift; + $self->{'_gtk'}; +} + +sub AUTOLOAD { + my $self = shift; + my $value = shift; + my($field)=$AUTOLOAD; + $field =~ s/.*://; + if ( defined($value) ) { + $self->{$field} = $value; + } else { + $self->{$field}; + } +} + +package FS::UI::_Text; + +use vars qw ( @ISA ); + +@ISA = qw ( FS::UI::_Widget ); + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + $self->{'_gtk'} = new Gtk::Label ( shift ); + bless ( $self, $class ); +} + +package FS::UI::_Link; + +use vars qw ( @ISA ); + +@ISA = qw ( FS::UI::_Widget ); + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = { @_ }; + $self->{'_gtk'} = new_with_label Gtk::Button ( $self->{'text'} ); + $self->{'_gtk'}->signal_connect( 'clicked', sub { + print "STUB: (Gtk) FS::UI::_Link"; + }, "hi", "there" ); + bless ( $self, $class ); +} + + +package FS::UI::_Table; + +use vars qw ( @ISA ); + +@ISA = qw ( FS::UI::_Widget ); + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = { @_ }; + bless ( $self, $class ); + + $self->{'_gtk'} = new Gtk::Table ( + $self->rows, + $self->columns, + 0, #homogeneous + ); + + $self; +} + +sub attach { + my $self = shift; + my ( $row, $column, $widget, $rowspan, $colspan ) = @_; + $rowspan ||= 1; + $colspan ||= 1; + $self->_gtk->attach_defaults( + $widget->_gtk, + $column, + $column + $colspan, + $row, + $row + $rowspan, + ); + $widget->_gtk->show; +} + +package FS::UI::_Tableborder; + +use vars qw ( @ISA ); + +@ISA = qw ( FS::UI::_Table ); + +=head1 VERSION + +$Id: Gtk.pm,v 1.1 1999-08-04 09:03:53 ivan Exp $ + +=head1 BUGS + +This documentation is incomplete. + +_Tableborder is just a _Table now. _Tableborders should scroll (but not the +headers) and need and need more decoration. (data in white section ala gtksql +and sliding field widths) headers should be buttons that callback to sort on +their fields. + +There should be a persistant, per-(freeside)-user store for window positions +and sizes and sort fields etc (see L<FS::UI::CGI/BUGS>. + +Still some small bits of widget code same as FS::UI::CGI. + +=head1 SEE ALSO + +L<FS::UI::Base> + +=head1 HISTORY + +$Log: Gtk.pm,v $ +Revision 1.1 1999-08-04 09:03:53 ivan +initial checkin of module files for proper perl installation + +Revision 1.1 1999/01/20 09:30:36 ivan +skeletal cross-UI UI code. + + +=cut + +1; + diff --git a/FS/FS/UI/agent.pm b/FS/FS/UI/agent.pm new file mode 100644 index 000000000..ce9744a55 --- /dev/null +++ b/FS/FS/UI/agent.pm @@ -0,0 +1,62 @@ +package FS::UI::agent; + +use strict; +use vars qw ( @ISA ); +use FS::UI::Base; +use FS::Record qw( qsearchs ); +use FS::agent; +use FS::agent_type; + +@ISA = qw ( FS::UI::Base ); + +sub db_table { 'agent' }; + +sub db_name { 'Agent' }; + +sub db_description { <<END; +Agents are resellers of your service. Agents may be limited to a subset of your +full offerings (via their type). +END +} + +sub list_fields { + 'agentnum', + 'typenum', +# 'freq', +# 'prog', +; } + +sub list_header { + 'Agent', + 'Type', +# 'Freq (n/a)', +# 'Prog (n/a)', +; } + +sub db_callback { + 'agentnum' => + sub { + my ( $agentnum, $record ) = @_; + my $agent = $record->agent; + new FS::UI::_Link ( + 'table' => 'agent', + 'method' => 'edit', + 'arg' => [ $agentnum ], + 'text' => "$agentnum: $agent", + ); + }, + 'typenum' => + sub { + my $typenum = shift; + my $agent_type = qsearchs( 'agent_type', { 'typenum' => $typenum } ); + my $atype = $agent_type->atype; + new FS::UI::_Link ( + 'table' => 'agent_type', + 'method' => 'edit', + 'arg' => [ $typenum ], + 'text' => "$typenum: $atype" + ); + }, +} + +1; diff --git a/FS/FS/UID.pm b/FS/FS/UID.pm new file mode 100644 index 000000000..f5c4f6139 --- /dev/null +++ b/FS/FS/UID.pm @@ -0,0 +1,285 @@ +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 $driver_name + $AutoCommit +); +use subs qw( + getsecrets cgisetotaker +); +use Exporter; +use Carp qw(carp croak cluck); +use DBI; +use FS::Conf; + +@ISA = qw(Exporter); +@EXPORT_OK = qw(checkeuid checkruid swapuid cgisuidsetup + adminsuidsetup getotaker dbh datasrc getsecrets driver_name ); + +$freeside_uid = scalar(getpwnam('freeside')); + +$conf_dir = "/usr/local/etc/freeside/"; + +$AutoCommit = 1; #ours, not DBI + +=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; + + $driver_name = driver_name; + +=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->disconnect if $dbh; + $dbh = DBI->connect($datasrc,$db_user,$db_pass, { + 'AutoCommit' => 0, + 'ChopBlanks' => 1, + } ) 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 + +Takes a single argument, which is a CGI (see L<CGI>) or Apache (see L<Apache>) +object (CGI::Base is depriciated). Runs cgisetotaker and then adminsuidsetup. + +=cut + +sub cgisuidsetup { + $cgi=shift; + if ( $cgi->isa('CGI::Base') ) { + carp "Use of CGI::Base is depriciated"; + } elsif ( $cgi->isa('Apache') ) { + + } elsif ( ! $cgi->isa('CGI') ) { + croak "fatal: unrecognized object $cgi"; + } + cgisetotaker; + adminsuidsetup($user); +} + +=item cgi + +Returns the CGI (see L<CGI>) object. + +=cut + +sub cgi { + carp "warning: \$FS::UID::cgi isa Apache" if $cgi->isa('Apache'); + $cgi; +} + +=item dbh + +Returns the DBI database handle. + +=cut + +sub dbh { + $dbh; +} + +=item datasrc + +Returns the DBI data source. + +=cut + +sub datasrc { + $datasrc; +} + +=item driver_name + +Returns just the driver name portion of the DBI data source. + +=cut + +sub driver_name { + return $driver_name if defined $driver_name; + $driver_name = ( split(':', $datasrc) )[1]; +} + +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 (see L<CGI>) or an Apache object (see L<Apache>). 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 ); + } elsif ( $cgi && $cgi->isa('Apache') ) { + $user = lc ( $cgi->connection->user ); + } else { + die "fatal: Can't get REMOTE_USER! for cgi $cgi"; + } + $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"; + undef $driver_name; + ($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.6 2001-04-23 09:00:06 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. + +=cut + +1; + diff --git a/FS/FS/agent.pm b/FS/FS/agent.pm new file mode 100644 index 000000000..1afe70641 --- /dev/null +++ b/FS/FS/agent.pm @@ -0,0 +1,160 @@ +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 if 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.2 2000-12-03 13:45:15 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. + +=cut + +1; + diff --git a/FS/FS/agent_type.pm b/FS/FS/agent_type.pm new file mode 100644 index 000000000..988533ae3 --- /dev/null +++ b/FS/FS/agent_type.pm @@ -0,0 +1,165 @@ +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.1 1999-08-04 09:03:53 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. + +=cut + +1; + diff --git a/FS/FS/cust_bill.pm b/FS/FS/cust_bill.pm new file mode 100644 index 000000000..8480ceadc --- /dev/null +++ b/FS/FS/cust_bill.pm @@ -0,0 +1,447 @@ +package FS::cust_bill; + +use strict; +use vars qw( @ISA $conf $invoice_template $money_char ); +use vars qw( $invoice_lines @buf ); #yuck +use Date::Format; +use Text::Template; +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; + + $money_char = $conf->config('money_char') || '$'; + + my @invoice_template = $conf->config('invoice_template') + or die "cannot load config file invoice_template"; + $invoice_lines = 0; + foreach ( grep /invoice_lines\(\d+\)/, @invoice_template ) { #kludgy + /invoice_lines\((\d+)\)/; + $invoice_lines += $1; + } + die "no invoice_lines() functions in template?" unless $invoice_lines; + $invoice_template = new Text::Template ( + TYPE => 'ARRAY', + SOURCE => [ map "$_\n", @invoice_template ], + ) or die "can't create new Text::Template object: $Text::Template::ERROR"; + $invoice_template->compile() + or die "can't compile template: $Text::Template::ERROR"; +}; + +=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; a declaration that a customer +owes you money. The specific charges are itemized as B<cust_bill_pkg> records +(see L<FS::cust_bill_pkg>). 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 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. + +=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 printed may be changed. 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; + + $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_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 owed + +Returns the amount owed (still outstanding) on this invoice, which is charged +minus all payments (see L<FS::cust_pay>). + +=cut + +sub owed { + my $self = shift; + my $balance = $self->charged; + $balance -= $_->paid foreach ( $self->cust_pay ); + $balance; +} + +=item print_text [TIME]; + +Returns an text 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; + + # + + #my @collect = (); + #my($description,$amount); + @buf = (); + + #previous balance + foreach ( @pr_cust_bill ) { + push @buf, [ + "Previous Balance, Invoice #". $_->invnum. + " (". time2str("%x",$_->_date). ")", + $money_char. sprintf("%10.2f",$_->owed) + ]; + } + if (@pr_cust_bill) { + push @buf,['','-----------']; + push @buf,[ 'Total Previous Balance', + $money_char. 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", $money_char. sprintf("%10.2f",$_->setup) ]; + push @buf, + map { [ " ". $_->[0]. ": ". $_->[1], '' ] } $cust_pkg->labels; + } + + if ( $_->recur != 0 ) { + push @buf, [ + "$pkg (" . time2str("%x",$_->sdate) . " - " . + time2str("%x",$_->edate) . ")", + $money_char. sprintf("%10.2f",$_->recur) + ]; + push @buf, + map { [ " ". $_->[0]. ": ". $_->[1], '' ] } $cust_pkg->labels; + } + + } else { #pkgnum Tax + push @buf,["Tax", $money_char. sprintf("%10.2f",$_->setup) ] + if $_->setup != 0; + } + } + + push @buf,['','-----------']; + push @buf,['Total New Charges', + $money_char. sprintf("%10.2f",$self->charged) ]; + push @buf,['','']; + + push @buf,['','-----------']; + push @buf,['Total Charges', + $money_char. sprintf("%10.2f",$self->charged + $pr_total) ]; + push @buf,['','']; + + #credits + foreach ( @cr_cust_credit ) { + push @buf,[ + "Credit #". $_->crednum. " (" . time2str("%x",$_->_date) .")", + $money_char. sprintf("%10.2f",$_->credited) + ]; + } + + #get & print payments + foreach ( $self->cust_pay ) { + push @buf,[ + "Payment received ". time2str("%x",$_->_date ), + $money_char. sprintf("%10.2f",$_->paid ) + ]; + } + + #balance due + push @buf,['','-----------']; + push @buf,['Balance Due', $money_char. + sprintf("%10.2f",$self->owed + $pr_total - $cr_total ) ]; + + #setup template variables + + package FS::cust_bill::_template; #! + use vars qw( $invnum $date $page $total_pages @address $overdue @buf ); + + $invnum = $self->invnum; + $date = $self->_date; + $page = 1; + + $total_pages = + int( scalar(@FS::cust_bill::buf) / $FS::cust_bill::invoice_lines ); + $total_pages++ + if scalar(@FS::cust_bill::buf) % $FS::cust_bill::invoice_lines; + + + #format address (variable for the template) + my $l = 0; + @address = ( '', '', '', '', '', '' ); + package FS::cust_bill; #! + $FS::cust_bill::_template::address[$l++] = + $cust_main->payname. + ( ( $cust_main->payby eq 'BILL' ) && $cust_main->payinfo + ? " (P.O. #". $cust_main->payinfo. ")" + : '' + ) + ; + $FS::cust_bill::_template::address[$l++] = $cust_main->company + if $cust_main->company; + $FS::cust_bill::_template::address[$l++] = $cust_main->address1; + $FS::cust_bill::_template::address[$l++] = $cust_main->address2 + if $cust_main->address2; + $FS::cust_bill::_template::address[$l++] = + $cust_main->city. ", ". $cust_main->state. " ". $cust_main->zip; + $FS::cust_bill::_template::address[$l++] = $cust_main->country + unless $cust_main->country eq 'US'; + + #overdue? (variable for the template) + $FS::cust_bill::_template::overdue = ( + $balance_due > 0 + && $today > $self->_date +# && $self->printed > 1 + && $self->printed > 0 + ); + + #and subroutine for the template + + sub FS::cust_bill::_template::invoice_lines { + my $lines = shift; + map { + scalar(@buf) ? shift @buf : [ '', '' ]; + } + ( 1 .. $lines ); + } + + $FS::cust_bill::_template::page = 1; + my $lines; + my @collect; + while (@buf) { + push @collect, split("\n", + $invoice_template->fill_in( PACKAGE => 'FS::cust_bill::_template' ) + ); + $FS::cust_bill::_template::page++; + } + + map "$_\n", @collect; + +} + +=back + +=head1 VERSION + +$Id: cust_bill.pm,v 1.7 2001-04-09 23:05:15 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. + +=cut + +1; + diff --git a/FS/FS/cust_bill_pkg.pm b/FS/FS/cust_bill_pkg.pm new file mode 100644 index 000000000..b3d3fcde2 --- /dev/null +++ b/FS/FS/cust_bill_pkg.pm @@ -0,0 +1,144 @@ +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>) or 0 for the special virtual sales tax package + +=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 2001-02-11 17:34:44 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. + +=cut + +1; + diff --git a/FS/FS/cust_credit.pm b/FS/FS/cust_credit.pm new file mode 100644 index 000000000..5888d07ef --- /dev/null +++ b/FS/FS/cust_credit.pm @@ -0,0 +1,167 @@ +package FS::cust_credit; + +use strict; +use vars qw( @ISA ); +use FS::UID qw( getotaker ); +use FS::Record qw( qsearchs ); +use FS::cust_main; +use FS::cust_refund; + +@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; the equivalent of a negative +B<cust_bill> record (see L<FS::cust_bill>). 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 _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. + +=item delete + +Currently unimplemented. + +=cut + +sub delete { + return "Can't remove credit!" +} + +=item replace OLD_RECORD + +Credits may not be modified; there would then be no record the credit was ever +posted. + +=cut + +sub replace { + return "Can't modify credit!" +} + +=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_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 +} + +=item cust_refund + +Returns all refunds (see L<FS::cust_refund>) for this credit. + +=cut + +sub cust_refund { + my $self = shift; + sort { $a->_date <=> $b->_date } + qsearch( 'cust_refund', { 'crednum' => $self->crednum } ) + ; +} + +=item credited + +Returns the amount of this credit that is still outstanding; which is +amount minus all refunds (see L<FS::cust_refund>). + +=cut + +sub credited { + my $self = shift; + my $amount = $self->amount; + $amount -= $_->refund foreach ( $self->cust_refund ); + $amount; +} + +=back + +=head1 VERSION + +$Id: cust_credit.pm,v 1.3 2001-04-09 23:05:15 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. + +=cut + +1; + diff --git a/FS/FS/cust_main.pm b/FS/FS/cust_main.pm new file mode 100644 index 000000000..0379f7f71 --- /dev/null +++ b/FS/FS/cust_main.pm @@ -0,0 +1,1152 @@ +#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 $Debug ); +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 dbh ); +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; +use FS::prepay_credit; + +@ISA = qw( FS::Record ); + +$Debug = 0; +#$Debug = 1; + +#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), `COMP' (free), or `PREPAY' (special billing type: applies a credit - see L<FS::prepay_credit> and sets billing type to BILL) + +=item payinfo - card number, P.O., comp issuer (4-8 lowercase alphanumerics; think username) or prepayment identifier (see L<FS::prepay_credit>) + +=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. + +There is a special insert mode in which you pass a data structure to the insert +method containing FS::cust_pkg and FS::svc_I<tablename> objects. When +running under a transactional database, all records are inserted atomicly, or +the transaction is rolled back. There should be a better explanation of this, +but until then, here's an example: + + use Tie::RefHash; + tie %hash, 'Tie::RefHash'; #this part is important + %hash = { + $cust_pkg => [ $svc_acct ], + }; + $cust_main->insert( \%hash ); + +=cut + +sub insert { + my $self = shift; + + 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 $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + my $amount = 0; + my $seconds = 0; + if ( $self->payby eq 'PREPAY' ) { + $self->payby('BILL'); + my $prepay_credit = qsearchs( + 'prepay_credit', + { 'identifier' => $self->payinfo }, + '', + 'FOR UPDATE' + ); + warn "WARNING: can't find pre-found prepay_credit: ". $self->payinfo + unless $prepay_credit; + $amount = $prepay_credit->amount; + $seconds = $prepay_credit->seconds; + my $error = $prepay_credit->delete; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + my $error = $self->SUPER::insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + if ( @_ ) { + my $cust_pkgs = shift; + foreach my $cust_pkg ( keys %$cust_pkgs ) { + $cust_pkg->custnum( $self->custnum ); + $error = $cust_pkg->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + foreach my $svc_something ( @{$cust_pkgs->{$cust_pkg}} ) { + $svc_something->pkgnum( $cust_pkg->pkgnum ); + if ( $seconds && $svc_something->isa('FS::svc_acct') ) { + $svc_something->seconds( $svc_something->seconds + $seconds ); + $seconds = 0; + } + $error = $svc_something->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + } + } + + if ( $seconds ) { + $dbh->rollback if $oldAutoCommit; + return "No svc_acct record to apply pre-paid time"; + } + + if ( $amount ) { + my $cust_credit = new FS::cust_credit { + 'custnum' => $self->custnum, + 'amount' => $amount, + }; + $error = $cust_credit->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; + +} + +=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; + + 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 $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + if ( qsearch( 'cust_bill', { 'custnum' => $self->custnum } ) ) { + $dbh->rollback if $oldAutoCommit; + return "Can't delete a customer with invoices"; + } + if ( qsearch( 'cust_credit', { 'custnum' => $self->custnum } ) ) { + $dbh->rollback if $oldAutoCommit; + return "Can't delete a customer with credits"; + } + + my @cust_pkg = qsearch( 'cust_pkg', { 'custnum' => $self->custnum } ); + if ( @cust_pkg ) { + my $new_custnum = shift; + unless ( qsearchs( 'cust_main', { 'custnum' => $new_custnum } ) ) { + $dbh->rollback if $oldAutoCommit; + return "Invalid new customer number: $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); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + } + foreach my $cust_main_invoice ( + qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } ) + ) { + my $error = $cust_main_invoice->delete; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + my $error = $self->SUPER::delete; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; + +} + +=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') + ; + #barf. need message catalogs. i18n. etc. + $error .= "Please select a referral." + if $error =~ /^Illegal or empty \(numeric\) refnum: /; + 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, + } ); + } + + $error = + $self->ut_phonen('daytime', $self->country) + || $self->ut_phonen('night', $self->country) + || $self->ut_phonen('fax', $self->country) + ; + return $error if $error; + + $self->zip =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/ + or return "Illegal zip: ". $self->zip; + $self->zip($1); + + $self->payby =~ /^(CARD|BILL|COMP|PREPAY)$/ + 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; + + } elsif ( $self->payby eq 'PREPAY' ) { + + my $payinfo = $self->payinfo; + $payinfo =~ s/\W//g; #anything else would just confuse things + $self->payinfo($payinfo); + $error = $self->ut_alpha('payinfo'); + return "Illegal prepayment identifier: ". $self->payinfo if $error; + return "Unknown prepayment identifier" + unless qsearchs('prepay_credit', { 'identifier' => $self->payinfo } ); + + } + + if ( $self->paydate eq '' || $self->paydate eq '-' ) { + return "Expriation date required" + unless $self->payby eq 'BILL' || $self->payby eq 'PREPAY'; + $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; + @{ [ # force list context + qsearch( 'cust_pkg', { + 'custnum' => $self->custnum, + 'cancel' => '', + }), + qsearch( 'cust_pkg', { + 'custnum' => $self->custnum, + 'cancel' => 0, + }), + ] }; +} + +=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'; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + # 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? CAREFUL with timezones (see + # mailing list archive) + #$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 undefined" unless defined($setup); + warn "recur is undefined" unless defined($recur); + warn "cust_pkg bill is undefined" 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 ); + + unless ( @cust_bill_pkg ) { + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + return ''; + } + + 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; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "$error for customer #". $self->custnum; + } + + 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? + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "$error for customer #". $self->custnum; + } + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; #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; + + #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'; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + my $total_owed = $self->balance; + warn "collect: total owed $total_owed " if $Debug; + unless ( $total_owed > 0 ) { #redundant????? + $dbh->rollback if $oldAutoCommit; + return ''; + } + + 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)" if $Debug; + + 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; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return 'Error COMPing invnum #'. $cust_bill->invnum. ": $error"; + } + + + } elsif ( $self->payby eq 'CARD' ) { + + if ( $options{'batch_card'} ne 'yes' ) { + + unless ( $processor ) { + $dbh->rollback if $oldAutoCommit; + return "Real time card processing not enabled!"; + } + + 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 { + $dbh->rollback if $oldAutoCommit; + return "Unknown real-time processor $processor"; + } + + #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; + if ( $error ) { + # gah, even with transactions. + $dbh->commit if $oldAutoCommit; #well. + my $e = 'WARNING: Card debited but database not updated - '. + 'error applying payment, invnum #' . $cust_bill->invnum. + " (CyberCash Order-ID $paybatch): $error"; + warn $e; + return $e; + } + } elsif ( $result{'Mstatus'} ne 'failure-bad-money' + || $options{'report_badcard'} ) { + $dbh->commit if $oldAutoCommit; + return 'Cybercash error, invnum #' . + $cust_bill->invnum. ':'. $result{'MErrMsg'}; + } else { + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + return ''; + } + + } else { + $dbh->rollback if $oldAutoCommit; + return "Unknown 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; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Error adding to cust_pay_batch: $error"; + } + + } + + } else { + $dbh->rollback if $oldAutoCommit; + return "Unknown payment type ". $self->payby; + } + + } + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; + +} + +=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.12 2001-04-23 07:12:44 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. + +=cut + +1; + + diff --git a/FS/FS/cust_main_county.pm b/FS/FS/cust_main_county.pm new file mode 100644 index 000000000..383360b7b --- /dev/null +++ b/FS/FS/cust_main_county.pm @@ -0,0 +1,111 @@ +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.1 1999-08-04 09:03:53 ivan Exp $ + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::Record>, L<FS::cust_main>, L<FS::cust_bill>, schema.html from the base +documentation. + +=cut + +1; + diff --git a/FS/FS/cust_main_invoice.pm b/FS/FS/cust_main_invoice.pm new file mode 100644 index 000000000..309691a43 --- /dev/null +++ b/FS/FS/cust_main_invoice.pm @@ -0,0 +1,181 @@ +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 svcnum (see L<FS::svc_acct>), 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.2 2000-06-20 07:13:03 ivan Exp $ + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::Record>, L<FS::cust_main> + +=cut + +1; + diff --git a/FS/FS/cust_pay.pm b/FS/FS/cust_pay.pm new file mode 100644 index 000000000..f0d945060 --- /dev/null +++ b/FS/FS/cust_pay.pm @@ -0,0 +1,174 @@ +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; the transfer of money from a +customer. 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 = $self->check; + return $error if $error; + + my $old_cust_bill = qsearchs( 'cust_bill', { 'invnum' => $self->invnum } ); + return "Unknown invnum" unless $old_cust_bill; + + $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.3 2001-04-09 23:05:15 ivan Exp $ + +=head1 BUGS + +Delete and replace methods. + +=head1 SEE ALSO + +L<FS::Record>, L<FS::cust_bill>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/cust_pay_batch.pm b/FS/FS/cust_pay_batch.pm new file mode 100644 index 000000000..0576cbefc --- /dev/null +++ b/FS/FS/cust_pay_batch.pm @@ -0,0 +1,205 @@ +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 country: ". $self->country; + $self->country($1); + + #check invnum, custnum, ? + + ''; #no error +} + +=back + +=head1 VERSION + +$Id: cust_pay_batch.pm,v 1.2 2000-06-17 21:48:05 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> + +=cut + +1; + diff --git a/FS/FS/cust_pkg.pm b/FS/FS/cust_pkg.pm new file mode 100644 index 000000000..9705827e7 --- /dev/null +++ b/FS/FS/cust_pkg.pm @@ -0,0 +1,588 @@ +package FS::cust_pkg; + +use strict; +use vars qw(@ISA); +use FS::UID qw( getotaker dbh ); +use FS::Record qw( qsearch qsearchs ); +use FS::cust_svc; +use FS::part_pkg; +use FS::cust_main; +use FS::type_pkgs; +use FS::pkg_svc; + +# 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; +use FS::svc_www; + +@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'; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + 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 do { + $dbh->rollback if $oldAutoCommit; + 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; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Error cancelling service: $error" + } + $error = $svc->delete; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Error deleting service: $error"; + } + } + + $error = $cust_svc->delete; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Error deleting cust_svc: $error"; + } + + } + + unless ( $self->getfield('cancel') ) { + my %hash = $self->hash; + $hash{'cancel'} = time; + my $new = new FS::cust_pkg ( \%hash ); + $error = $new->replace($self); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; #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'; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + 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 do { + $dbh->rollback if $oldAutoCommit; + 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; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + } + + unless ( $self->getfield('susp') ) { + my %hash = $self->hash; + $hash{'susp'} = time; + my $new = new FS::cust_pkg ( \%hash ); + $error = $new->replace($self); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; #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'; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + 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 do { + $dbh->rollback if $oldAutoCommit; + 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; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + } + + unless ( ! $self->getfield('susp') ) { + my %hash = $self->hash; + $hash{'susp'} = ''; + my $new = new FS::cust_pkg ( \%hash ); + $error = $new->replace($self); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; #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)=@_; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + # 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} ) { + unless ( $part_pkg{$pkgpart} ) { + $dbh->rollback if $oldAutoCommit; + return "Customer not permitted to purchase pkgpart $pkgpart!"; + } + push @cust_svc, [ + map { + ( $svcnum{$_} && @{ $svcnum{$_} } ) ? shift @{ $svcnum{$_} } : (); + } map { $_->svcpart } qsearch('pkg_svc', { 'pkgpart' => $pkgpart }) + ]; + } + + #check for leftover services + foreach (keys %svcnum) { + next unless @{ $svcnum{$_} }; + $dbh->rollback if $oldAutoCommit; + return "Leftover services, svcpart $_: svcnum ". + join(', ', map { $_->svcnum } @{ $svcnum{$_} } ); + } + + #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}); + unless ( $old ) { + $dbh->rollback if $oldAutoCommit; + die "Package $pkgnum not found to remove!"; + } + my(%hash) = $old->hash; + $hash{'cancel'}=time; + my($new) = new FS::cust_pkg ( \%hash ); + my($error)=$new->replace($old); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + die "Couldn't update package $pkgnum: $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; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + die "Couldn't insert new cust_pkg record: $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); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + die "Couldn't link old service to new package: $error"; + } + } + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; #no errors +} + +=back + +=head1 VERSION + +$Id: cust_pkg.pm,v 1.5 2001-04-09 23:05:15 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 + +=cut + +1; + diff --git a/FS/FS/cust_refund.pm b/FS/FS/cust_refund.pm new file mode 100644 index 000000000..729dc02b0 --- /dev/null +++ b/FS/FS/cust_refund.pm @@ -0,0 +1,173 @@ +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: the transfer of money to a customer; +equivalent to a negative payment (see L<FS::cust_pay>). 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 = $self->check; + return $error if $error; + + my $old_cust_credit = + qsearchs( 'cust_credit', { 'crednum' => $self->crednum } ); + return "Unknown crednum" unless $old_cust_credit; + + $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 2001-04-09 23:05:15 ivan Exp $ + +=head1 BUGS + +Delete and replace methods. + +=head1 SEE ALSO + +L<FS::Record>, L<FS::cust_credit>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/cust_svc.pm b/FS/FS/cust_svc.pm new file mode 100644 index 000000000..cbc4d91fa --- /dev/null +++ b/FS/FS/cust_svc.pm @@ -0,0 +1,167 @@ +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.1 1999-08-04 09:03:53 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 + +=cut + +1; + diff --git a/FS/FS/domain_record.pm b/FS/FS/domain_record.pm new file mode 100644 index 000000000..9b7081b2c --- /dev/null +++ b/FS/FS/domain_record.pm @@ -0,0 +1,182 @@ +package FS::domain_record; + +use strict; +use vars qw( @ISA ); +#use FS::Record qw( qsearch qsearchs ); +use FS::Record qw( qsearchs ); +use FS::svc_domain; + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::domain_record - Object methods for domain_record records + +=head1 SYNOPSIS + + use FS::domain_record; + + $record = new FS::domain_record \%hash; + $record = new FS::domain_record { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::domain_record object represents an entry in a DNS zone. +FS::domain_record inherits from FS::Record. The following fields are currently +supported: + +=over 4 + +=item recnum - primary key + +=item svcnum - Domain (see L<FS::svc_domain>) of this entry + +=item reczone - partial (or full) zone for this entry + +=item recaf - address family for this entry, currently only `IN' is recognized. + +=item rectype - record type for this entry (A, MX, etc.) + +=item recdata - data for this entry + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new entry. 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 { 'domain_record'; } + +=item insert + +Adds this record to the database. If there is an error, returns the error, +otherwise returns false. + +=cut + +=item delete + +Delete this record from the database. + +=cut + +=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 + +=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; + + my $error = + $self->ut_numbern('recnum') + || $self->ut_number('svcnum') + ; + return $error if $error; + + return "Unknown svcnum (in svc_domain)" + unless qsearchs('svc_domain', { 'svcnum' => $self->svcnum } ); + + $self->reczone =~ /^(@|[a-z0-9\.\-]+)$/ + or return "Illegal reczone: ". $self->reczone; + $self->reczone($1); + + $self->recaf =~ /^(IN)$/ or return "Illegal recaf: ". $self->recaf; + $self->recaf($1); + + $self->rectype =~ /^(SOA|NS|MX|A|PTR|CNAME)$/ + or return "Illegal rectype (only SOA NS MX A PTR CNAME recognized): ". + $self->rectype; + $self->rectype($1); + + if ( $self->rectype eq 'SOA' ) { + my $recdata = $self->recdata; + $recdata =~ s/\s+/ /g; + $recdata =~ /^([a-z0-9\.\-]+ [\w\-\+]+\.[a-z0-9\.\-]+ \( (\d+ ){5}\))$/ + or return "Illegal data for SOA reocrd: $recdata"; + $self->recdata($1); + } elsif ( $self->rectype eq 'NS' ) { + $self->recdata =~ /^([a-z0-9\.\-]+)$/ + or return "Illegal data for NS record: ". $self->recdata; + $self->recdata($1); + } elsif ( $self->rectype eq 'MX' ) { + $self->recdata =~ /^(\d+)\s+([a-z0-9\.\-]+)$/ + or return "Illegal data for MX record: ". $self->recdata; + $self->recdata("$1 $2"); + } elsif ( $self->rectype eq 'A' ) { + $self->recdata =~ /^((\d{1,3}\.){3}\d{1,3})$/ + or return "Illegal data for A record: ". $self->recdata; + $self->recdata($1); + } elsif ( $self->rectype eq 'PTR' ) { + $self->recdata =~ /^([a-z0-9\.\-]+)$/ + or return "Illegal data for PTR record: ". $self->recdata; + $self->recdata($1); + } elsif ( $self->rectype eq 'CNAME' ) { + $self->recdata =~ /^([a-z0-9\.\-]+)$/ + or return "Illegal data for CNAME record: ". $self->recdata; + $self->recdata($1); + } else { + die "ack!"; + } + + ''; #no error +} + +=back + +=head1 VERSION + +$Id: domain_record.pm,v 1.1 2000-02-03 05:16:52 ivan Exp $ + +=head1 BUGS + +The data validation doesn't check everything it could. In particular, +there is no protection against bad data that passes the regex, duplicate +SOA records, forgetting the trailing `.', impossible IP addersses, etc. Of +course, it's still better than editing the zone files directly. :) + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=head1 HISTORY + +$Log: domain_record.pm,v $ +Revision 1.1 2000-02-03 05:16:52 ivan +beginning of DNS and Apache support + + +=cut + +1; + diff --git a/FS/FS/nas.pm b/FS/FS/nas.pm new file mode 100644 index 000000000..cb0c1b901 --- /dev/null +++ b/FS/FS/nas.pm @@ -0,0 +1,150 @@ +package FS::nas; + +use strict; +use vars qw( @ISA ); +use FS::Record qw(qsearchs); #qsearch); +use FS::UID qw( dbh ); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::nas - Object methods for nas records + +=head1 SYNOPSIS + + use FS::nas; + + $record = new FS::nas \%hash; + $record = new FS::nas { + 'nasnum' => 1, + 'nasip' => '10.4.20.23', + 'nasfqdn' => 'box1.brc.nv.us.example.net', + }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + + $error = $record->heartbeat($timestamp); + +=head1 DESCRIPTION + +An FS::nas object represents an Network Access Server on your network, such as +a terminal server or equivalent. FS::nas inherits from FS::Record. The +following fields are currently supported: + +=over 4 + +=item nasnum - primary key + +=item nas - NAS name + +=item nasip - NAS ip address + +=item nasfqdn - NAS fully-qualified domain name + +=item last - timestamp indicating the last instant the NAS was in a known + state (used by the session monitoring). + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new NAS. To add the NAS 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 { 'nas'; } + +=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; + + $self->ut_numbern('nasnum') + || $self->ut_text('nas') + || $self->ut_ip('nasip') + || $self->ut_domain('nasfqdn') + || $self->ut_numbern('last'); +} + +=item heartbeat TIMESTAMP + +Updates the timestamp for this nas + +=cut + +sub heartbeat { + my($self, $timestamp) = @_; + my $dbh = dbh; + my $sth = + $dbh->prepare("UPDATE nas SET last = ? WHERE nasnum = ? AND last < ?"); + $sth->execute($timestamp, $self->nasnum, $timestamp) or die $sth->errstr; + $self->last($timestamp); +} + +=back + +=head1 VERSION + +$Id: nas.pm,v 1.5 2001-04-15 13:35:12 ivan Exp $ + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/part_pkg.pm b/FS/FS/part_pkg.pm new file mode 100644 index 000000000..d262a04e0 --- /dev/null +++ b/FS/FS/part_pkg.pm @@ -0,0 +1,186 @@ +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 (with non-zero quantity). + +=cut + +sub pkg_svc { + my $self = shift; + grep { $_->quantity } 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.2 1999-08-20 08:27:06 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. + +=cut + +1; + diff --git a/FS/FS/part_referral.pm b/FS/FS/part_referral.pm new file mode 100644 index 000000000..3f0af4b8e --- /dev/null +++ b/FS/FS/part_referral.pm @@ -0,0 +1,110 @@ +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.1 1999-08-04 09:03:53 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. + +=cut + +1; + diff --git a/FS/FS/part_svc.pm b/FS/FS/part_svc.pm new file mode 100644 index 000000000..01487b75f --- /dev/null +++ b/FS/FS/part_svc.pm @@ -0,0 +1,165 @@ +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.1 1999-08-04 09:03:53 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. + +=cut + +1; + diff --git a/FS/FS/pkg_svc.pm b/FS/FS/pkg_svc.pm new file mode 100644 index 000000000..1812dbf29 --- /dev/null +++ b/FS/FS/pkg_svc.pm @@ -0,0 +1,152 @@ +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.1 1999-08-04 09:03:53 ivan Exp $ + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::Record>, L<FS::part_pkg>, L<FS::part_svc>, schema.html from the base +documentation. + +=cut + +1; + diff --git a/FS/FS/port.pm b/FS/FS/port.pm new file mode 100644 index 000000000..13455ca89 --- /dev/null +++ b/FS/FS/port.pm @@ -0,0 +1,160 @@ +package FS::port; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearchs ); +use FS::nas; +use FS::session; + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::port - Object methods for port records + +=head1 SYNOPSIS + + use FS::port; + + $record = new FS::port \%hash; + $record = new FS::port { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + + $session = $port->session; + +=head1 DESCRIPTION + +An FS::port object represents an individual port on a NAS. FS::port inherits +from FS::Record. The following fields are currently supported: + +=over 4 + +=item portnum - primary key + +=item ip - IP address of this port + +=item nasport - port number on the NAS + +=item nasnum - NAS this port is on - see L<FS::nas> + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new port. 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 { 'port'; } + +=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; + my $error = + $self->ut_numbern('portnum') + || $self->ut_ipn('ip') + || $self->ut_numbern('nasport') + || $self->ut_number('nasnum'); + ; + return $error if $error; + return "Either ip or nasport must be specified" + unless $self->ip || $self->nasport; + return "Unknown nasnum" + unless qsearchs('nas', { 'nasnum' => $self->nasnum } ); + ''; #no error +} + +=item session + +Returns the currently open session on this port, or if no session is currently +open, the most recent session. See L<FS::session>. + +=cut + +sub session { + my $self = shift; + qsearchs('session', { 'portnum' => $self->portnum }, '*', + 'ORDER BY login DESC LIMIT 1' ); +} + +=back + +=head1 VERSION + +$Id: port.pm,v 1.5 2001-02-14 04:33:06 ivan Exp $ + +=head1 BUGS + +The author forgot to customize this manpage. + +The session method won't deal well if you have multiple open sessions on a +port, for example if your RADIUS server drops B<stop> records. Suggestions for +how to deal with this sort of lossage welcome; should we close the session +when we get a new session on that port? Tag it as invalid somehow? Close it +one second after it was opened? *sigh* Maybe FS::session shouldn't let you +create overlapping sessions, at least folks will find out their logging is +dropping records. + +If you think the above refers multiple user logins you need to read the +manpages again. + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/prepay_credit.pm b/FS/FS/prepay_credit.pm new file mode 100644 index 000000000..113cee823 --- /dev/null +++ b/FS/FS/prepay_credit.pm @@ -0,0 +1,131 @@ +package FS::prepay_credit; + +use strict; +use vars qw( @ISA ); +#use FS::Record qw( qsearch qsearchs ); +use FS::Record qw(); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::prepay_credit - Object methods for prepay_credit records + +=head1 SYNOPSIS + + use FS::prepay_credit; + + $record = new FS::prepay_credit \%hash; + $record = new FS::prepay_credit { + 'identifier' => '4198123455512121' + 'amount' => '19.95', + }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::table_name object represents an pre--paid credit, such as a pre-paid +"calling card". FS::prepay_credit inherits from FS::Record. The following +fields are currently supported: + +=over 4 + +=item field - description + +=item identifier - identifier entered by the user to receive the credit + +=item amount - amount of the credit + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new pre-paid credit. 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 { 'prepay_credit'; } + +=item insert + +Adds this record to the database. If there is an error, returns the error, +otherwise returns false. + +=cut + +=item delete + +Delete this record from the database. + +=cut + +=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 + +=item check + +Checks all fields to make sure this is a valid pre-paid 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 $identifier = $self->identifier; + $identifier =~ s/\W//g; #anything else would just confuse things + $self->identifier($identifier); + + $self->ut_numbern('prepaynum') + || $self->ut_alpha('identifier') + || $self->ut_money('amount') + ; + +} + +=back + +=head1 VERSION + +$Id: prepay_credit.pm,v 1.2 2000-02-02 20:22:18 ivan Exp $ + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=head1 HISTORY + +$Log: prepay_credit.pm,v $ +Revision 1.2 2000-02-02 20:22:18 ivan +bugfix prepayment in signup server + +Revision 1.1 2000/01/31 05:22:23 ivan +prepaid "internet cards" + + +=cut + +1; + diff --git a/FS/FS/session.pm b/FS/FS/session.pm new file mode 100644 index 000000000..de0f2a76a --- /dev/null +++ b/FS/FS/session.pm @@ -0,0 +1,269 @@ +package FS::session; + +use strict; +use vars qw( @ISA $conf $start $stop ); +use FS::UID qw( dbh ); +use FS::Record qw( qsearchs ); +use FS::svc_acct; +use FS::port; +use FS::nas; + +@ISA = qw(FS::Record); + +$FS::UID::callback{'FS::session'} = sub { + $conf = new FS::Conf; + $start = $conf->exists('session-start') ? $conf->config('session-start') : ''; + $stop = $conf->exists('session-stop') ? $conf->config('session-stop') : ''; +}; + +=head1 NAME + +FS::session - Object methods for session records + +=head1 SYNOPSIS + + use FS::session; + + $record = new FS::session \%hash; + $record = new FS::session { + 'portnum' => 1, + 'svcnum' => 2, + 'login' => $timestamp, + 'logout' => $timestamp, + }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + + $error = $record->nas_heartbeat($timestamp); + +=head1 DESCRIPTION + +An FS::session object represents an user login session. FS::session inherits +from FS::Record. The following fields are currently supported: + +=over 4 + +=item sessionnum - primary key + +=item portnum - NAS port for this session - see L<FS::port> + +=item svcnum - User for this session - see L<FS::svc_acct> + +=item login - timestamp indicating the beginning of this user session. + +=item logout - timestamp indicating the end of this user session. May be null, + which indicates a currently open session. + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new session. To add the session 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 { 'session'; } + +=item insert + +Adds this record to the database. If there is an error, returns the error, +otherwise returns false. If the `login' field is empty, it is replaced with +the current time. + +=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 $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + if ( qsearchs('session', { 'portnum' => $self->portnum, 'logout' => '' } ) ) { + $dbh->rollback if $oldAutoCommit; + return "a session on that port is already open!"; + } + + $self->setfield('login', time()) unless $self->getfield('login'); + + $error = $self->SUPER::insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + $self->nas_heartbeat($self->getfield('login')); + + #session-starting callback + #redundant with heartbeat, yuck + my $port = qsearchs('port',{'portnum'=>$self->portnum}); + my $nas = qsearchs('nas',{'nasnum'=>$port->nasnum}); + #kcuy + my( $ip, $nasip, $nasfqdn ) = ( $port->ip, $nas->nasip, $nas->nasfqdn ); + system( eval qq("$start") ) if $start; + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; + +} + +=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. If the `logout' field is empty, +it is replaced with the current time. + +=cut + +sub replace { + my($self, $old) = @_; + 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 $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + $error = $self->check; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + $self->setfield('logout', time()) unless $self->getfield('logout'); + + $error = $self->SUPER::replace($old); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + $self->nas_heartbeat($self->getfield('logout')); + + #session-ending callback + #redundant with heartbeat, yuck + my $port = qsearchs('port',{'portnum'=>$self->portnum}); + my $nas = qsearchs('nas',{'nasnum'=>$port->nasnum}); + #kcuy + my( $ip, $nasip, $nasfqdn ) = ( $port->ip, $nas->nasip, $nas->nasfqdn ); + system( eval qq("$stop") ) if $stop; + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; +} + +=item check + +Checks all fields to make sure this is a valid session. 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; + my $error = + $self->ut_numbern('sessionnum') + || $self->ut_number('portnum') + || $self->ut_number('svcnum') + || $self->ut_numbern('login') + || $self->ut_numbern('logout') + ; + return $error if $error; + return "Unknown svcnum" + unless qsearchs('svc_acct', { 'svcnum' => $self->svcnum } ); + ''; +} + +=item nas_heartbeat + +Heartbeats the nas associated with this session (see L<FS::nas>). + +=cut + +sub nas_heartbeat { + my $self = shift; + my $port = qsearchs('port',{'portnum'=>$self->portnum}); + my $nas = qsearchs('nas',{'nasnum'=>$port->nasnum}); + $nas->heartbeat(shift); +} + +=item svc_acct + +Returns the svc_acct record associated with this session (see L<FS::svc_acct>). + +=cut + +sub svc_acct { + my $self = shift; + qsearchs('svc_acct', { 'svcnum' => $self->svcnum } ); +} + +=back + +=head1 VERSION + +$Id: session.pm,v 1.7 2001-04-15 13:35:12 ivan Exp $ + +=head1 BUGS + +Maybe you shouldn't be able to insert a session if there's currently an open +session on that port. Or maybe the open session on that port should be flagged +as problematic? autoclosed? *sigh* + +Hmm, sessions refer to current svc_acct records... probably need to constrain +deletions to svc_acct records such that no svc_acct records are deleted which +have a session (even if long-closed). + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/svc_Common.pm b/FS/FS/svc_Common.pm new file mode 100644 index 000000000..bc5b75640 --- /dev/null +++ b/FS/FS/svc_Common.pm @@ -0,0 +1,213 @@ +package FS::svc_Common; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearchs fields dbh ); +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'; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + $error = $self->check; + return $error if $error; + + my $svcnum = $self->svcnum; + my $cust_svc; + unless ( $svcnum ) { + $cust_svc = new FS::cust_svc ( { + #hua?# 'svcnum' => $svcnum, + 'pkgnum' => $self->pkgnum, + 'svcpart' => $self->svcpart, + } ); + $error = $cust_svc->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + $svcnum = $self->svcnum($cust_svc->svcnum); + } + + $error = $self->SUPER::insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; +} + +=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.4 2001-04-22 00:49:30 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. + +=cut + +1; + diff --git a/FS/FS/svc_acct.pm b/FS/FS/svc_acct.pm new file mode 100644 index 000000000..79104b883 --- /dev/null +++ b/FS/FS/svc_acct.pm @@ -0,0 +1,561 @@ +package FS::svc_acct; + +use strict; +use vars qw( @ISA $nossh_hack $conf $dir_prefix @shells $usernamemin + $usernamemax $passwordmin + $shellmachine $useradd $usermod $userdel + @saltset @pw_set); +use Carp; +use FS::Conf; +use FS::Record qw( qsearchs fields ); +use FS::svc_Common; +use Net::SSH qw(ssh); +use FS::part_svc; +use FS::svc_acct_pop; +use FS::svc_acct_sm; + +@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'); + $usernamemin = $conf->config('usernamemin') || 2; + $usernamemax = $conf->config('usernamemax'); + $passwordmin = $conf->config('passwordmin') || 6; + if ( $shellmachine ) { + if ( $conf->exists('shellmachine-useradd') ) { + $useradd = join("\n", $conf->config('shellmachine-useradd') ) + || 'cp -pr /etc/skel $dir; chown -R $uid.$gid $dir'; + } else { + $useradd = 'useradd -d $dir -m -s $shell -u $uid $username'; + } + if ( $conf->exists('shellmachine-userdel') ) { + $userdel = join("\n", $conf->config('shellmachine-userdel') ) + || 'rm -rf $dir'; + } else { + $userdel = 'userdel $username'; + } + $usermod = join("\n", $conf->config('shellmachine-usermod') ) + || '[ -d $old_dir ] && mv $old_dir $new_dir || ( '. + 'chmod u+t $old_dir; 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'. + ')'; + } +}; + +@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; + + %hash = $record->radius; + +=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(s) specified in +the shellmachine-useradd configuration are exectued on shellmachine via ssh. +This behaviour can be surpressed by setting $FS::svc_acct::nossh_hack true. +If the shellmachine-useradd configuration file does not exist, + + useradd -d $dir -m -s $shell -u $uid $username + +is the default. If the shellmachine-useradd configuration file exists but +it empty, + + cp -pr /etc/skel $dir; chown -R $uid.$gid $dir + +is the default instead. Otherwise the contents of the file are treated as +a double-quoted perl string, with the following variables available: +$username, $uid, $gid, $dir, and $shell. + +=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 "Unknown 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, $gid, $dir, $shell ) = ( + $self->username, + $self->uid, + $self->gid, + $self->dir, + $self->shell, + ); + if ( $username && $uid && $dir && $shellmachine && ! $nossh_hack ) { + ssh("root\@$shellmachine", eval qq("$useradd") ); + } + + ''; #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(s) specified in the shellmachine-userdel configuration file are +executed on shellmachine via ssh. This behavior can be surpressed by setting +$FS::svc_acct::nossh_hack true. If the shellmachine-userdel configuration +file does not exist, + + userdel $username + +is the default. If the shellmachine-userdel configuration file exists but +is empty, + + rm -rf $dir + +is the default instead. Otherwise the contents of the file are treated as a +double-quoted perl string, with the following variables available: +$username and $dir. + +=cut + +sub delete { + my $self = shift; + my $error; + + return "Can't delete an account which has mail aliases pointed to it!" + if $self->uid && qsearch( 'svc_acct_sm', { 'domuid' => $self->uid } ); + + 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, $dir ) = ( + $self->username, + $self->dir, + ); + if ( $username && $shellmachine && ! $nossh_hack ) { + ssh("root\@$shellmachine", eval qq("$userdel") ); + } + + ''; +} + +=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(s) specified in the shellmachine-usermod +configuraiton file are executed on shellmachine via ssh. This behavior can +be surpressed by setting $FS::svc-acct::nossh_hack true. If the +shellmachine-userdel configuration file does not exist or is empty, : + + [ -d $old_dir ] && mv $old_dir $new_dir || ( + chmod u+t $old_dir; + 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, $uid, $gid ) = ( + $old->getfield('dir'), + $new->getfield('dir'), + $new->getfield('uid'), + $new->getfield('gid'), + ); + if ( $old_dir && $new_dir && $old_dir ne $new_dir && ! $nossh_hack ) { + ssh("root\@$shellmachine", eval qq("$usermod") ); + } + + ''; #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 = $usernamemax || $self->dbdef_table->column('username')->length; + $recref->{username} =~ /^([a-z0-9_\-\.]{$usernamemin,$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}; + $recref->{popnum} = $1; + return "Unknown 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' ) { + if ( grep $_ eq $recref->{shell}, @shells ) { + $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0]; + } 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]{$passwordmin,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,34})$/ ) { + $recref->{_password} = $1.$3; + } elsif ( $recref->{_password} eq '*' ) { + $recref->{_password} = '*'; + } else { + return "Illegal password"; + } + + ''; #no error +} + +=item radius + +Depriciated, use radius_reply instead. + +=cut + +sub radius { + carp "FS::svc_acct::radius depriciated, use radius_reply"; + $_[0]->radius_reply; +} + +=item radius_reply + +Returns key/value pairs, suitable for assigning to a hash, for any RADIUS +reply attributes of this record. + +Note that this is now the preferred method for reading RADIUS attributes - +accessing the columns directly is discouraged, as the column names are +expected to change in the future. + +=cut + +sub radius_reply { + my $self = shift; + map { + /^(radius_(.*))$/; + my($column, $attrib) = ($1, $2); + $attrib =~ s/_/\-/g; + ( $attrib, $self->getfield($column) ); + } grep { /^radius_/ && $self->getfield($_) } fields( $self->table ); +} + +=item radius_check + +Returns key/value pairs, suitable for assigning to a hash, for any RADIUS +check attributes of this record. + +Accessing RADIUS attributes directly is not supported and will break in the +future. + +=cut + +sub radius_check { + my $self = shift; + map { + /^(rc_(.*))$/; + my($column, $attrib) = ($1, $2); + $attrib =~ s/_/\-/g; + ( $attrib, $self->getfield($column) ); + } grep { /^rc_/ && $self->getfield($_) } fields( $self->table ); +} + +=cut + +=head1 VERSION + +$Id: svc_acct.pm,v 1.15 2001-04-22 01:56:15 ivan Exp $ + +=head1 BUGS + +The bits which ssh should fork before doing so (or maybe queue jobs for a +daemon). + +The $recref stuff in sub check should be cleaned up. + +The suspend, unsuspend and cancel methods update the database, but not the +current object. This is probably a bug as it's unexpected and +counterintuitive. + +=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<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>, +schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/svc_acct_pop.pm b/FS/FS/svc_acct_pop.pm new file mode 100644 index 000000000..5e755ef73 --- /dev/null +++ b/FS/FS/svc_acct_pop.pm @@ -0,0 +1,114 @@ +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 + +=item loc - rest of number + +=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') + or $self->ut_numbern('loc') + ; + +} + +=back + +=head1 VERSION + +$Id: svc_acct_pop.pm,v 1.2 2000-01-28 22:55:06 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. + +=cut + +1; + diff --git a/FS/FS/svc_acct_sm.pm b/FS/FS/svc_acct_sm.pm new file mode 100644 index 000000000..8cec60b69 --- /dev/null +++ b/FS/FS/svc_acct_sm.pm @@ -0,0 +1,253 @@ +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 Net::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 } ) + && ! $conf->exists('maildisablecatchall'); + + $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.3 2001-04-22 01:56: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<Net::SSH>, L<ssh>, L<dot-qmail>, +schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/svc_domain.pm b/FS/FS/svc_domain.pm new file mode 100644 index 000000000..a70c1a340 --- /dev/null +++ b/FS/FS/svc_domain.pm @@ -0,0 +1,506 @@ +package FS::svc_domain; + +use strict; +use vars qw( @ISA $whois_hack $conf $mydomain $smtpmachine + $tech_contact $from $to @nameservers @nameserver_ips @template + @mxmachines @nsmachines $soadefaultttl $soaemail $soaexpire $soamachine + $soarefresh $soaretry +); +use Carp; +use Mail::Internet; +use Mail::Header; +use Date::Format; +use Net::Whois 1.0; +use FS::Record qw(fields qsearch qsearchs dbh); +use FS::Conf; +use FS::svc_Common; +use FS::cust_svc; +use FS::svc_acct; +use FS::cust_pkg; +use FS::cust_main; +use FS::domain_record; + +@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"); + + @mxmachines = $conf->config('mxmachines'); + @nsmachines = $conf->config('nsmachines'); + $soadefaultttl = $conf->config('soadefaultttl'); + $soaemail = $conf->config('soaemail'); + $soaexpire = $conf->config('soaexpire'); + $soamachine = $conf->config('soamachine'); + $soarefresh = $conf->config('soarefresh'); + $soaretry = $conf->config('soaretry'); + +}; + +=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. + +If any I<soamachine> configuration file exists, an SOA record is added to +the domain_record table (see <FS::domain_record>). + +If any machines are defined in the I<nsmachines> configuration file, NS +records are added to the domain_record table (see L<FS::domain_record>). + +If any machines are defined in the I<mxmachines> configuration file, MX +records are added to the domain_record table (see L<FS::domain_record>). + +Any problems adding FS::domain_record records will emit warnings, but will +not return errors from this method. If your configuration files are correct +you shouln't have any problems. + +=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'; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + $error = $self->check; + return $error if $error; + + return "Domain in use (here)" + if qsearchs( 'svc_domain', { 'domain' => $self->domain } ); + + my $whois = $self->whois; + if ( $self->action eq "N" && ! $whois_hack && $whois ) { + $dbh->rollback if $oldAutoCommit; + return "Domain in use (see whois)"; + } + if ( $self->action eq "M" && ! $whois ) { + $dbh->rollback if $oldAutoCommit; + return "Domain not found (see whois)"; + } + + $error = $self->SUPER::insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + $self->submit_internic unless $whois_hack; + + if ( $soamachine ) { + my $soa = new FS::domain_record { + 'svcnum' => $self->svcnum, + 'reczone' => '@', + 'recaf' => 'IN', + 'rectype' => 'SOA', + 'recdata' => "$soamachine $soaemail ( ". time2str("%Y%m%e", time). "00 ". + "$soarefresh $soaretry $soaexpire $soadefaultttl )" + }; + $error = $soa->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "couldn't insert SOA record for new domain: $error"; + } + + foreach my $nsmachine ( @nsmachines ) { + my $ns = new FS::domain_record { + 'svcnum' => $self->svcnum, + 'reczone' => '@', + 'recaf' => 'IN', + 'rectype' => 'NS', + 'recdata' => $nsmachine, + }; + my $error = $ns->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "couldn't insert NS record for new domain: $error"; + } + } + + foreach my $mxmachine ( @mxmachines ) { + my $mx = new FS::domain_record { + 'svcnum' => $self->svcnum, + 'reczone' => '@', + 'recaf' => 'IN', + 'rectype' => 'mx', + 'recdata' => $mxmachine, + }; + my $error = $mx->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "couldn't insert MX record for new domain: $error"; + } + } + + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; #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::Domain object (see L<Net::Whois>) for 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.10 2001-04-22 01:56:15 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<Net::Whois>, L<ssh>, +L<dot-qmail>, schema.html from the base documentation, config.html from the +base documentation. + +=cut + +1; + + diff --git a/FS/FS/svc_www.pm b/FS/FS/svc_www.pm new file mode 100644 index 000000000..bce69d6a9 --- /dev/null +++ b/FS/FS/svc_www.pm @@ -0,0 +1,251 @@ +package FS::svc_www; + +use strict; +use vars qw(@ISA $conf $apacheroot $apachemachine $nossh_hack ); +#use FS::Record qw( qsearch qsearchs ); +use FS::Record qw( qsearchs ); +use FS::svc_Common; +use FS::cust_svc; +use FS::domain_record; +use FS::svc_acct; +use Net::SSH qw(ssh); + +@ISA = qw( FS::svc_Common ); + +#ask FS::UID to run this stuff for us later +$FS::UID::callback{'FS::svc_www'} = sub { + $conf = new FS::Conf; + $apacheroot = $conf->config('apacheroot'); + $apachemachine = $conf->config('apachemachine'); +}; + +=head1 NAME + +FS::svc_www - Object methods for svc_www records + +=head1 SYNOPSIS + + use FS::svc_www; + + $record = new FS::svc_www \%hash; + $record = new FS::svc_www { '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_www object represents an web virtual host. FS::svc_www inherits +from FS::svc_Common. The following fields are currently supported: + +=over 4 + +=item svcnum - primary key + +=item recnum - DNS `A' record corresponding to this web virtual host. (see L<FS::domain_record>) + +=item usersvc - account (see L<FS::svc_acct>) corresponding to this web virtual host. + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new web virtual host. 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 { 'svc_www'; } + +=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. + +If the configuration values (see L<FS::Conf>) I<apachemachine>, and +I<apacheroot> exist, the command: + + mkdir $apacheroot/$zone; + chown $username $apacheroot/$zone; + ln -s $apacheroot/$zone $homedir/$zone + +I<$zone> is the DNS A record pointed to by I<recnum> +I<$username> is the username pointed to by I<usersvc> +I<$homedir> is that user's home directory + +is executed on I<apachemachine> via ssh. This behaviour can be surpressed by +setting $FS::svc_www::nossh_hack true. + +=cut + +sub insert { + my $self = shift; + my $error; + + $error = $self->SUPER::insert; + return $error if $error; + + my $domain_record = qsearchs('domain_record', { 'recnum' => $self->recnum } ); # or die ? + my $zone = $domain_record->reczone; + # or die ? + unless ( $zone =~ /\.$/ ) { + my $dom_svcnum = $domain_record->svcnum; + my $svc_domain = qsearchs('svc_domain', { 'svcnum' => $dom_svcnum } ); + # or die ? + $zone .= $svc_domain->domain; + } + + my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $self->usersvc } ); + # or die ? + my $username = $svc_acct->username; + # or die ? + my $homedir = $svc_acct->dir; + # or die ? + + if ( $apachemachine + && $apacheroot + && $zone + && $username + && $homedir + && ! $nossh_hack + ) { + ssh("root\@$apachemachine", + "mkdir $apacheroot/$zone; ". + "chown $username $apacheroot/$zone; ". + "ln -s $apacheroot/$zone $homedir/$zone" + ); + } + + ''; +} + +=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; + + my $error = + $self->ut_numbern('svcnum') + || $self->ut_number('recnum') + || $self->ut_number('usersvc') + ; + return $error if $error; + + return "Unknown recnum: ". $self->recnum + unless qsearchs('domain_record', { 'recnum' => $self->recnum } ); + + return "Unknown usersvc (svc_acct.svcnum): ". $self->usersvc + unless qsearchs('svc_acct', { 'svcnum' => $self->usersvc } ); + + ''; #no error +} + +=back + +=head1 VERSION + +$Id: svc_www.pm,v 1.4 2001-04-22 01:56:15 ivan Exp $ + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::svc_Common>, L<FS::Record>, L<FS::domain_record>, L<FS::cust_svc>, +L<FS::part_svc>, L<FS::cust_pkg>, schema.html from the base documentation. + +=head1 HISTORY + +$Log: svc_www.pm,v $ +Revision 1.4 2001-04-22 01:56:15 ivan +get rid of FS::SSH.pm (became Net::SSH and Net::SCP on CPAN) + +Revision 1.3 2000/11/22 23:30:51 ivan +tyop + +Revision 1.2 2000/03/01 08:13:59 ivan +compilation bugfixes + +Revision 1.1 2000/02/03 05:16:52 ivan +beginning of DNS and Apache support + + +=cut + +1; + diff --git a/FS/FS/type_pkgs.pm b/FS/FS/type_pkgs.pm new file mode 100644 index 000000000..8e0d4ef56 --- /dev/null +++ b/FS/FS/type_pkgs.pm @@ -0,0 +1,113 @@ +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.1 1999-08-04 09:03:53 ivan Exp $ + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::Record>, L<FS::agent_type>, L<FS::part_pkgs>, schema.html from the base +documentation. + +=cut + +1; + diff --git a/FS/MANIFEST b/FS/MANIFEST new file mode 100644 index 000000000..98f76acda --- /dev/null +++ b/FS/MANIFEST @@ -0,0 +1,48 @@ +Changes +FS.pm +FS/CGI.pm +FS/Conf.pm +FS/Record.pm +FS/UI/Base.pm +FS/UI/CGI.pm +FS/UI/Gtk.pm +FS/UI/agent.pm +FS/UID.pm +FS/agent.pm +FS/agent_type.pm +FS/cust_bill.pm +FS/cust_bill_pkg.pm +FS/cust_credit.pm +FS/cust_main.pm +FS/cust_main_county.pm +FS/cust_main_invoice.pm +FS/cust_pay.pm +FS/cust_pay_batch.pm +FS/cust_pkg.pm +FS/cust_refund.pm +FS/cust_svc.pm +FS/part_pkg.pm +FS/part_referral.pm +FS/part_svc.pm +FS/pkg_svc.pm +FS/svc_Common.pm +FS/svc_acct.pm +FS/svc_acct_pop.pm +FS/svc_acct_sm.pm +FS/svc_domain.pm +FS/type_pkgs.pm +FS/nas.pm +FS/port.pm +FS/session.pm +MANIFEST +MANIFEST.SKIP +Makefile.PL +test.pl +README +bin/freeside-bill +bin/freeside-print-batch +bin/freeside-disable-overdue +FS/domain_record.pm +FS/prepay_credit.pm +FS/svc_www.pm +FS/CGIwrapper.pm diff --git a/FS/MANIFEST.SKIP b/FS/MANIFEST.SKIP new file mode 100644 index 000000000..ae335e78a --- /dev/null +++ b/FS/MANIFEST.SKIP @@ -0,0 +1 @@ +CVS/ diff --git a/FS/Makefile.PL b/FS/Makefile.PL new file mode 100644 index 000000000..ab4c2281b --- /dev/null +++ b/FS/Makefile.PL @@ -0,0 +1,8 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + 'NAME' => 'FS', + 'VERSION_FROM' => 'FS.pm', # finds $VERSION + 'EXE_FILES' => [ glob 'bin/*' ], +); diff --git a/FS/README b/FS/README new file mode 100644 index 000000000..d4c35acb4 --- /dev/null +++ b/FS/README @@ -0,0 +1,6 @@ +This is the Perl module section of Freeside. + +perl Makefile.PL +make +make test +make install diff --git a/FS/bin/freeside-bill b/FS/bin/freeside-bill new file mode 100755 index 000000000..42991c4f8 --- /dev/null +++ b/FS/bin/freeside-bill @@ -0,0 +1,126 @@ +#!/usr/bin/perl -Tw + +use strict; +use Fcntl qw(:flock); +use Date::Parse; +use Getopt::Std; +use FS::UID qw(adminsuidsetup swapuid); +use FS::Record qw(qsearch qsearchs); +use FS::cust_main; + +&untaint_argv; #what it sounds like (eww) +use vars qw($opt_a $opt_c $opt_i $opt_d); +getopts("acid:"); +my $user = shift or die &usage; + +adminsuidsetup $user; + +my %bill_only = map { $_ => 1 } ( + @ARGV ? @ARGV : ( map $_->custnum, qsearch('cust_main', {} ) ) +); + +#we're at now now (and later). +my($time)= $main::opt_d ? str2time($main::opt_d) : $^T; + +# find packages w/ bill < time && cancel != '', and create corresponding +# customer objects + +my($cust_main,%saw); +foreach $cust_main ( + map { + unless ( exists $saw{ $_->custnum } && defined $saw{ $_->custnum} ) { + $saw{ $_->custnum } = 0; # to avoid 'use of uninitialized value' errors + } + if ( + ( $main::opt_a || ( ( $_->getfield('bill') || 0 ) <= $time ) ) + && $bill_only{ $_->custnum } + && !$saw{ $_->custnum }++ + ) { + qsearchs('cust_main',{'custnum'=> $_->custnum } ); + } else { + (); + } + } ( qsearch('cust_pkg', { 'cancel' => '' }), + qsearch('cust_pkg', { 'cancel' => 0 }), + ) +) { + + # and bill them + + print "Billing customer #" . $cust_main->getfield('custnum') . "\n"; + + my($error); + + $error=$cust_main->bill('time'=>$time); + warn "Error billing, customer #" . $cust_main->getfield('custnum') . + ":" . $error if $error; + + if ($main::opt_c) { + $error=$cust_main->collect('invoice_time'=>$time, + 'batch_card' => $main::opt_i ? 'no' : 'yes', + ); + warn "Error collecting customer #" . $cust_main->getfield('custnum') . + ":" . $error if $error; + + #sleep 1; + + } + +} + +# subroutines + +sub untaint_argv { + foreach $_ ( $[ .. $#ARGV ) { #untaint @ARGV + #$ARGV[$_] =~ /^([\w\-\/]*)$/ || die "Illegal arguement \"$ARGV[$_]\""; + # Date::Parse + $ARGV[$_] =~ /^(.*)$/ || die "Illegal arguement \"$ARGV[$_]\""; + $ARGV[$_]=$1; + } +} + +sub usage { + die "Usage:\n\n freeside-bill [ -c [ i ] ] [ -d 'date' ] [ -b ] user\n"; +} + +=head1 NAME + +freeside-bill - Command line (crontab, script) interface to customer billing. + +=head1 SYNOPSIS + + freeside-bill [ -c [ -a ] [ -i ] ] [ -d 'date' ] user [ custnum custnum ... ] + +=head1 DESCRIPTION + +Bills customers. Searches for customers who are due for billing and calls +the bill and collect methods of a cust_main object. See L<FS::cust_main>. + + -c: Turn on collecting (you probably want this). + + -a: Call collect even if there isn't a new invoice (probably a bad idea for + daily use) + + -i: real-time billing (as opposed to batch billing). only relevant + for credit cards. + + -d: Pretend it's 'date'. Date is in any format Date::Parse is happy with, + but be careful. + +user: From the mapsecrets file - see config.html from the base documentation + +custnum: if one or more customer numbers are specified, only bills those +customers. Otherwise, bills all customers. + +=head1 VERSION + +$Id: freeside-bill,v 1.6 2000-06-24 00:28:30 ivan Exp $ + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::cust_main>, config.html from the base documentation + +=cut + diff --git a/FS/bin/freeside-print-batch b/FS/bin/freeside-print-batch new file mode 100755 index 000000000..5efa4ccb3 --- /dev/null +++ b/FS/bin/freeside-print-batch @@ -0,0 +1,269 @@ +#!/usr/bin/perl -Tw + +use strict; +#use Date::Format; +use Time::Local; +use Getopt::Std; +use FS::Conf; +use FS::UID qw(adminsuidsetup); +use FS::Record qw(qsearch); +use FS::cust_pay; +use FS::cust_pay_batch; + +# Get the currennt time and date +my $time = time; +my ($sec,$min,$hour,$mday,$mon,$year) = + (localtime($time) )[0,1,2,3,4,5]; +my $_date = + timelocal($sec,$min,$hour,$mday,$mon,$year); + +# Set the mail program +my $mail_program = "/usr/sbin/sendmail -t -n"; + +&untaint_argv; #what it sounds like (eww) +use vars qw($opt_v $opt_p $opt_e $opt_a $opt_d); +getopts("vpead"); #switches + +# Login to the database +my $user = shift or die &usage; +adminsuidsetup $user; + +# Get the needed configuration files +my $conf = new FS::Conf; +my $lpr = $conf->config('lpr'); +my $email = $conf->config('email'); + +my(@batch)=qsearch('cust_pay_batch',{}); +if (scalar(@batch) == 0) +{ + exit 1; +} + +# Open print and email pipes +# $lpr and opt_p for printing +# $email and opt_e for email +# +if ($lpr && $main::opt_p) +{ + open(LPR, "|$lpr"); + print LPR qq~C R E D I T C A R D P A Y M E N T S D U E $mon/$mday/$year\n\n~; +} + +if ($email && $main::opt_e) +{ + open (MAIL, "|$mail_program"); + print MAIL <<END +To: $email +From: Account Processor +Subject: CREDIT CARD PAYMENTS DUE + + +C R E D I T C A R D P A Y M E N T S D U E $mon/$mday/$year +END +} + +# Now I can start looping +foreach my $cust_pay_batch (@batch) +{ + my $state = $cust_pay_batch->getfield('state'); + my $zip = $cust_pay_batch->getfield('zip'); + my $amount = $cust_pay_batch->getfield('amount'); + my $last = $cust_pay_batch->getfield('last'); + my $address1 = $cust_pay_batch->getfield('address1'); + my $address2 = $cust_pay_batch->getfield('address2'); + my $first = $cust_pay_batch->getfield('first'); + my $city = $cust_pay_batch->getfield('city'); + my $cardnum = $cust_pay_batch->getfield('cardnum'); + my $payname = $cust_pay_batch->getfield('payname'); + my $exp = $cust_pay_batch->getfield('exp'); + my $invnum = $cust_pay_batch->getfield('invnum'); + my $custnum = $cust_pay_batch->getfield('custnum'); + + # Need a carriage return in address before address2 + # if it exists. Otherwise address will just be address1 + my $address = $address1; + $address .= "\n$address2" if ($address2); + + # Only print to the screen in verbose mode + if ($main::opt_v) + { + printf("Invoice %d for %s %s\tCustomer Number: %d\n", + $invnum, + $first, + $last, + $custnum); + + printf("\t%s\n", $address); + printf("\t%s, %s, %s\n\n", + $city, + $state, + $zip); + + printf("\tCard Number: %s\tExp:%s\n", + $cardnum, + $exp); + printf("\t\tName: %s\n", $payname); + printf("\t\tAmount: %.2f\n\n\n", $amount); + } + + if ($lpr && $main::opt_p) + { + printf(LPR "Invoice %d for %s %s\tCustomer Number: %d\n", + $invnum, + $first, + $last, + $custnum); + + printf(LPR "\t%s\n", $address); + printf(LPR "\t%s, %s, %s\n\n", + $city, + $state, + $zip); + + printf(LPR "\tCard Number: %s\tExp:%s\n", + $cardnum, + $exp); + printf(LPR "\t\tName: %s\n", $payname); + printf(LPR "\t\tAmount: %.2f\n\n\n", $amount); + } + + if ($email && $main::opt_e) + { + printf(MAIL "Invoice %d for %s %s\tCustomer Number: %d\n", + $invnum, + $first, + $last, + $custnum); + + printf(MAIL "\t%s\n", $address); + printf(MAIL "\t%s, %s, %s\n\n", + $city, + $state, + $zip); + + printf(MAIL "\tCard Number: %s\tExp:%s\n", + $cardnum, + $exp); + printf(MAIL "\t\tName: %s\n", $payname); + printf(MAIL "\t\tAmount: %.2f\n\n\n", $amount); + } + + # Now I want to delete the records from cust_pay_batch + # and mark the records in cust_pay as paid today if + # the delete (-d) command line option is set. + if($main::opt_a) + { + my $payment=new FS::cust_pay { + 'invnum' => $invnum, + 'paid' => $amount, + '_date' => $_date, + 'payby' => "CARD", + 'payinfo' => $cardnum, + 'paybatch' => "AUTO", + }; + + my $pay_error=$payment->insert; + if ($pay_error) + { + # warn might be better if you get root's mail + # NEED TO TEST THIS BEFORE DELETE IF WARN IS USED + die "Could not update cust_pay for invnum $invnum. $pay_error\n"; + } + } + + # This just deletes the records + # Must be last in the foreach loop + if($main::opt_d) + { + my $del_error = $cust_pay_batch->delete; + if ($del_error) + { + die "Could not delete cust_pay_batch for invnum $invnum. $del_error\n"; + } + } + +} + +# Now I need to close LPR and EMAIL if they were open +if($lpr && $main::opt_p) +{ + close LPR || die "Could not close printer: $lpr\n"; +} + +if($email && $main::opt_e) +{ + close MAIL || die "Could not close printer: $lpr\n"; +} + + +# subroutines +sub untaint_argv { + foreach $_ ( $[ .. $#ARGV ) { #untaint @ARGV + $ARGV[$_] =~ /^([\w\-\/]*)$/ || die "Illegal argument \"$ARGV[$_]\""; + $ARGV[$_]=$1; + } +} + +sub usage { + die "Usage:\n\n freeside-print-batch [-v] [-p] [-e] [-a] [-d] user\n"; +} + +=head1 NAME + +freeside-print-batch - Prints or emails cust_pay_batch. Also deletes + old records and adds payment to cust_pay. + Usually run after the bill command. + +=head1 SYNOPSIS + + freeside-print-batch [-v] [-p] [-e] [-a] [-d] user + +=head1 DESCRIPTION + +Prints or emails cust_pay_batch. Can enter payment and delete +printed records. Usually run as a cron job. + +B<-v>: Verbose - Prints records to STDOUT. + +B<-p>: Print to printer lpr as found in the conf directory. + +B<-e>: Email output to user found in the Conf email file. + +B<-a>: Automatically pays all records in cust_pay_batch. Use -d with this option usually. + +B<-d>: Delete - Pays account and deletes record from cust_pay_batch. + +user: From the mapsecrets file - see config.html from the base documentation + +=head1 VERSION + +$Id: freeside-print-batch,v 1.2 2001-02-21 01:48:07 ivan Exp $ + +=head1 BUGS + +Yes..... Use at your own risk. No guarantees or warrantees of any +kind apply to this program. Parts of this program are hacked from +other GNU licensed software created mainly by Ivan Kohler. + +This is released under the GNU Public License. See www.gnu.org +for more information regarding this license. + +=head1 SEE ALSO + +L<FS::cust_main>, config.html from the base documentation + +=head1 HISTORY + +griff@aver-computer.com July 99 + +$Log: freeside-print-batch,v $ +Revision 1.2 2001-02-21 01:48:07 ivan +stupid pod errors + +Revision 1.1 2000/05/13 21:57:56 ivan +add print_batch script from Joel Griffiths + + +=cut + + diff --git a/FS/test.pl b/FS/test.pl new file mode 100644 index 000000000..dc3726236 --- /dev/null +++ b/FS/test.pl @@ -0,0 +1,20 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..1\n"; } +END {print "not ok 1\n" unless $loaded;} +use FS; +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): + |