diff options
Diffstat (limited to 'FS')
116 files changed, 19083 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..60831ecd5 --- /dev/null +++ b/FS/FS.pm @@ -0,0 +1,199 @@ +package FS; + +use strict; +use vars qw($VERSION); + +$VERSION = '0.01'; + +1; +__END__ + +=head1 NAME + +FS - Freeside Perl modules + +=head1 SYNOPSIS + +Freeside perl modules and CLI utilities. + +=head2 Utility classes + +L<FS::Conf> - Freeside configuration values + +L<FS::ConfItem> - Freeside configuration option meta-data. + +L<FS::UID> - User class (not yet OO) + +L<FS::CGI> - Non OO-subroutines for the web interface. + +=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_pop_local> - Local calling area 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_forward> - Mail forwarding class + +L<FS::svc_acct_sm> - (Depreciated) Vitual mail alias class + +L<FS::svc_www> - Web virtual host class. + +L<FS::part_svc> - Service definition class + +L<FS::part_svc_column> - Column constraint class + +L<FS::part_export> - External provisioning export class + +L<FS::part_export_option> - Export option 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::part_bill_event> - Invoice event definition class + +L<FS::cust_bill_event> - Completed invoice event class + +L<FS::cust_pay> - Payment class + +L<FS::cust_bill_pay> - Payment application class + +L<FS::cust_credit> - Credit class + +L<FS::cust_refund> - Refund class + +L<FS::cust_credit_refund> - Refund application class + +L<FS::cust_credit_bill> - Credit invoice application 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 + +L<FS::queue> - Job queue + +L<FS::queue_arg> - Job arguments + +=head1 Remote API modules + +L<FS::SignupClient> + +L<FS::SessionClient> + +L<FS::MailAdminServer> + +=head2 Command-line utilities + +L<freeside-email> + +L<freeside-queued> + +L<freeside-adduser> + +L<freeside-bill> + +L<freeside-overdue> + +=head2 User Interface classes (under (stalled) 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." + +If you've never used OO modules before, +http://www.cpan.org/doc/FMTEYEWTK/easy_objects.html might help you out. + +=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 httemplate/docs. + +=head1 SUPPORT + +A mailing list for users is available. Send a blank message to +<ivan-freeside-subscribe@sisd.com> to subscribe. + +A mailing list for developers is available. It is intended to be lower volume +and higher SNR than the users list. Send a blank message to +<ivan-freeside-devel-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 + +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..190c0aa37 --- /dev/null +++ b/FS/FS/CGI.pm @@ -0,0 +1,314 @@ +package FS::CGI; + +use strict; +use vars qw(@EXPORT_OK @ISA @header); +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 + small_custview myexit); + +=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,$etc)=@_; #$etc is for things like onLoad= etc. + #use Carp; + $etc = '' unless defined $etc; + + my $x = <<END; + <HTML> + <HEAD> + <TITLE> + $title + </TITLE> + <META HTTP-Equiv="Cache-Control" Content="no-cache"> + <META HTTP-Equiv="Pragma" Content="no-cache"> + <META HTTP-Equiv="Expires" Content="0"> + </HEAD> + <BODY BGCOLOR="#e8e8e8"$etc> + <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 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( @FS::CGI::header ); +# } + print <<END; +<HTML> + <HEAD> + <TITLE>Error processing your request</TITLE> + <META HTTP-Equiv="Cache-Control" Content="no-cache"> + <META HTTP-Equiv="Pragma" Content="no-cache"> + <META HTTP-Equiv="Expires" Content="0"> + </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 an HTML error message, then exits. + +=cut + +sub eidiot { + warn "eidiot depriciated"; + $HTML::Mason::Commands::r->send_http_header + if defined $HTML::Mason::Commands::r; + idiot(@_); + &myexit(); +} + +=item myexit + +You probably shouldn't use this; but if you must: + +If running under mod_perl, calles Apache::exit, otherwise, calls exit. + +=cut + +sub myexit { + if (exists $ENV{MOD_PERL}) { + + if ( defined $main::Response + && $main::Response->isa('Apache::ASP::Response') ) { #Apache::ASP + $main::Response->End(); + require Apache; + Apache::exit(); + } elsif ( defined $HTML::Mason::Commands::m ) { #Mason + #$HTML::Mason::Commands::m->flush_buffer(); + $HTML::Mason::Commands::m->abort(); + die "shouldn't fall through to here (mason \$m->abort didn't)"; + } else { + #??? well, it is $ENV{MOD_PERL} + warn "running under unknown mod_perl environment; trying Apache::exit()"; + require 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%" CELLSPACING=0 CELLPADDING=2 BORDERCOLOR="#999999">!; + } else { + '<TABLE BORDER=1 CELLSPACING=0 CELLPADDING=2 BORDERCOLOR="#999999">'; + } +} + +=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 CELLSPACING=0 CELLPADDING=2 BORDERCOLOR="#999999">'; + } + +} + +=item small_custview CUSTNUM || CUST_MAIN_OBJECT, COUNTRYDEFAULT + +Sheesh. I should just switch to Mason. + +=cut + +sub small_custview { + use FS::Record qw(qsearchs); + use FS::cust_main; + + my $arg = shift; + my $countrydefault = shift || 'US'; + + my $cust_main = ref($arg) ? $arg + : qsearchs('cust_main', { 'custnum' => $arg } ) + or die "unknown custnum $arg"; + + my $html = 'Customer #<B>'. $cust_main->custnum. '</B>'. + ntable('#e8e8e8'). '<TR><TD>'. ntable("#cccccc",2). + '<TR><TD ALIGN="right" VALIGN="top">Billing</TD><TD BGCOLOR="#ffffff">'. + $cust_main->getfield('last'). ', '. $cust_main->first. '<BR>'; + + $html .= $cust_main->company. '<BR>' if $cust_main->company; + $html .= $cust_main->address1. '<BR>'; + $html .= $cust_main->address2. '<BR>' if $cust_main->address2; + $html .= $cust_main->city. ', '. $cust_main->state. ' '. $cust_main->zip. '<BR>'; + $html .= $cust_main->country. '<BR>' + if $cust_main->country && $cust_main->country ne $countrydefault; + + $html .= '</TD></TR></TABLE></TD>'; + + if ( defined $cust_main->dbdef_table->column('ship_last') ) { + + my $pre = $cust_main->ship_last ? 'ship_' : ''; + + $html .= '<TD>'. ntable("#cccccc",2). + '<TR><TD ALIGN="right" VALIGN="top">Service</TD><TD BGCOLOR="#ffffff">'. + $cust_main->get("${pre}last"). ', '. + $cust_main->get("${pre}first"). '<BR>'; + $html .= $cust_main->get("${pre}company"). '<BR>' + if $cust_main->get("${pre}company"); + $html .= $cust_main->get("${pre}address1"). '<BR>'; + $html .= $cust_main->get("${pre}address2"). '<BR>' + if $cust_main->get("${pre}address2"); + $html .= $cust_main->get("${pre}city"). ', '. + $cust_main->get("${pre}state"). ' '. + $cust_main->get("${pre}ship_zip"). '<BR>'; + $html .= $cust_main->get("${pre}country"). '<BR>' + if $cust_main->get("${pre}country") + && $cust_main->get("${pre}country") ne $countrydefault; + + $html .= '</TD></TR></TABLE></TD>'; + } + + $html .= '</TR></TABLE>'; + + $html; +} + +=back + +=head1 BUGS + +Not OO. + +Not complete. + +small_custview sooooo doesn't belong here. i should just switch to Mason. + +=head1 SEE ALSO + +L<CGI>, L<CGI::Base> + +=cut + +1; + + diff --git a/FS/FS/Conf.pm b/FS/FS/Conf.pm new file mode 100644 index 000000000..226702e5c --- /dev/null +++ b/FS/FS/Conf.pm @@ -0,0 +1,779 @@ +package FS::Conf; + +use vars qw($default_dir @config_items $DEBUG ); +use IO::File; +use FS::ConfItem; + +$DEBUG = 0; + +=head1 NAME + +FS::Conf - 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'); + + @config_items = $conf->config_items; + +=head1 DESCRIPTION + +Read and write 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 =~ /^(.*)$/; + $1; +} + +=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"; +} + +=item touch + +=cut + +sub touch { + my($self, $file) = @_; + my $dir = $self->dir; + unless ( $self->exists($file) ) { + warn "[FS::Conf] TOUCH $file\n" if $DEBUG; + system('touch', "$dir/$file"); + } +} + +=item set + +=cut + +sub set { + my($self, $file, $value) = @_; + my $dir = $self->dir; + $value =~ /^(.*)$/s; + $value = $1; + unless ( $self->config($file) eq $value ) { + warn "[FS::Conf] SET $file\n" if $DEBUG; +# warn "$dir" if is_tainted($dir); +# warn "$dir" if is_tainted($file); + chmod 0644, "$dir/$file"; + my $fh = new IO::File ">$dir/$file" or return; + chmod 0644, "$dir/$file"; + print $fh "$value\n"; + } +} +#sub is_tainted { +# return ! eval { join('',@_), kill 0; 1; }; +# } + +=item delete + +=cut + +sub delete { + my($self, $file) = @_; + my $dir = $self->dir; + if ( $self->exists($file) ) { + warn "[FS::Conf] DELETE $file\n"; + unlink "$dir/$file"; + } +} + +=item config_items + +Returns all of the possible configuration items as FS::ConfItem objects. See +L<FS::ConfItem>. + +=cut + +sub config_items { +# my $self = shift; + @config_items; +} + +=back + +=head1 BUGS + +Write access (touch, set, delete) should be documented. + +If this was more than just crud that will never be useful outside Freeside I'd +worry that config_items is freeside-specific and icky. + +=head1 SEE ALSO + +"Configuration" in the web interface (config/config.cgi). + +httemplate/docs/config.html + +=cut + +@config_items = map { new FS::ConfItem $_ } ( + + { + 'key' => 'address', + 'section' => 'depreciated', + 'description' => 'This configuration option is no longer used. See <a href="#invoice_template">invoice_template</a> instead.', + 'type' => 'text', + }, + + { + 'key' => 'apacheroot', + 'section' => 'apache', + 'description' => 'The directory containing Apache virtual hosts', + 'type' => 'text', + }, + + { + 'key' => 'apacheip', + 'section' => 'apache', + 'description' => 'The current IP address to assign to new virtual hosts', + 'type' => 'text', + }, + + { + 'key' => 'apachemachine', + 'section' => 'apache', + 'description' => 'A machine with the apacheroot directory and user home directories. The existance of this file enables setup of virtual host directories, and, in conjunction with the `home\' configuration file, symlinks into user home directories.', + 'type' => 'text', + }, + + { + 'key' => 'apachemachines', + 'section' => 'apache', + 'description' => 'Your Apache machines, one per line. This enables export of `/etc/apache/vhosts.conf\', which can be included in your Apache configuration via the <a href="http://www.apache.org/docs/mod/core.html#include">Include</a> directive.', + 'type' => 'textarea', + }, + + { + 'key' => 'bindprimary', + 'section' => 'BIND', + 'description' => 'Your BIND primary nameserver. This enables export of /var/named/named.conf and zone files into /var/named', + 'type' => 'text', + }, + + { + 'key' => 'bindsecondaries', + 'section' => 'BIND', + 'description' => 'Your BIND secondary nameservers, one per line. This enables export of /var/named/named.conf', + 'type' => 'textarea', + }, + + { + 'key' => 'business-onlinepayment', + 'section' => 'billing', + 'description' => '<a href="http://search.cpan.org/search?mode=module&query=Business%3A%3AOnlinePayment">Business::OnlinePayment</a> support, at least three lines: processor, login, and password. An optional fourth line specifies the action or actions (multiple actions are separated with `,\': for example: `Authorization Only, Post Authorization\'). Optional additional lines are passed to Business::OnlinePayment as %processor_options.', + 'type' => 'textarea', + }, + + { + 'key' => 'bsdshellmachines', + 'section' => 'shell', + 'description' => 'Your BSD flavored shell (and mail) machines, one per line. This enables export of `/etc/passwd\' and `/etc/master.passwd\'.', + 'type' => 'textarea', + }, + + { + 'key' => 'countrydefault', + 'section' => 'UI', + 'description' => 'Default two-letter country code (if not supplied, the default is `US\')', + 'type' => 'text', + }, + + { + 'key' => 'cybercash3.2', + 'section' => 'billing', + 'description' => '<a href="http://www.cybercash.com/cashregister/">CyberCash Cashregister v3.2</a> support. Two lines: the full path and name of your merchant_conf file, and the transaction type (`mauthonly\' or `mauthcapture\').', + 'type' => 'textarea', + }, + + { + 'key' => 'cyrus', + 'section' => 'mail', + 'description' => 'Integration with <a href="http://asg.web.cmu.edu/cyrus/imapd/">Cyrus IMAP Server</a>, three lines: IMAP server, admin username, and admin password. Cyrus::IMAP::Admin should be installed locally and the connection to the server secured.', + 'type' => 'textarea', + }, + + { + 'key' => 'cp_app', + 'section' => 'mail', + 'description' => 'Integration with <a href="http://www.cp.net/">Critial Path Account Provisioning Protocol</a>, four lines: "host:port", username, password, and workgroup (for new users).', + 'type' => 'textarea', + }, + + { + 'key' => 'deletecustomers', + 'section' => 'UI', + 'description' => 'Enable customer deletions. Be very careful! Deleting a customer will remove all traces that this customer ever existed! It should probably only be used when auditing a legacy database. Normally, you cancel all of a customers\' packages if they cancel service.', + 'type' => 'checkbox', + }, + + { + 'key' => 'deletepayments', + 'section' => 'UI', + 'description' => 'Enable deletion of unclosed payments. Be very careful! Only delete payments that were data-entry errors, not adjustments.', + 'type' => 'checkbox', + }, + + { + 'key' => 'dirhash', + 'section' => 'shell', + 'description' => 'Optional numeric value to control directory hashing. If positive, hashes directories for the specified number of levels from the front of the username. If negative, hashes directories for the specified number of levels from the end of the username. Some examples: <ul><li>1: user -> <a href="#home">/home</a>/u/user<li>2: user -> <a href="#home">/home</a>/u/s/user<li>-1: user -> <a href="#home">/home</a>/r/user<li>-2: user -> <a href="#home">home</a>/r/e/user</ul>', + 'type' => 'text', + }, + + { + 'key' => 'disable_customer_referrals', + 'section' => 'UI', + 'description' => 'Disable new customer-to-customer referrals in the web interface', + 'type' => 'checkbox', + }, + + { + 'key' => 'domain', + 'section' => 'depreciated', + 'description' => 'Your domain name.', + 'type' => 'text', + }, + + { + 'key' => 'editreferrals', + 'section' => 'UI', + 'description' => 'Enable referral modification for existing customers', + 'type' => 'checkbox', + }, + + { + 'key' => 'emailinvoiceonly', + 'section' => 'billing', + 'description' => 'Disables postal mail invoices', + 'type' => 'checkbox', + }, + + { + 'key' => 'disablepostalinvoicedefault', + 'section' => 'billing', + 'description' => 'Disables postal mail invoices as the default option in the UI. Be careful not to setup customers which are not sent invoices. See <a href ="#emailinvoiceauto">emailinvoiceauto</a>.', + 'type' => 'checkbox', + }, + + { + 'key' => 'emailinvoiceauto', + 'section' => 'billing', + 'description' => 'Automatically adds new accounts to the email invoice list upon customer creation', + 'type' => 'checkbox', + }, + + { + 'key' => 'erpcdmachines', + 'section' => '', + 'description' => 'Your ERPCD authenticaion machines, one per line. This enables export of `/usr/annex/acp_passwd\' and `/usr/annex/acp_dialup\'', + 'type' => 'textarea', + }, + + { + 'key' => 'hidecancelledpackages', + 'section' => 'UI', + 'description' => 'Prevent cancelled packages from showing up in listings (though they will still be in the database)', + 'type' => 'checkbox', + }, + + { + 'key' => 'hidecancelledcustomers', + 'section' => 'UI', + 'description' => 'Prevent customers with only cancelled packages from showing up in listings (though they will still be in the database)', + 'type' => 'checkbox', + }, + + { + 'key' => 'home', + 'section' => 'required', + 'description' => 'For new users, prefixed to username to create a directory name. Should have a leading but not a trailing slash.', + 'type' => 'text', + }, + + { + 'key' => 'icradiusmachines', + 'section' => 'radius', + 'description' => 'Turn this option on to enable radcheck and radreply table population - by default in the Freeside database, or in the database specified by the <a href="http://rootwood.haze.st/aspside/config/config-view.cgi#icradius_secrets">icradius_secrets</a> config option (the radcheck and radreply tables needs to be created manually). You do not need to use MySQL for your Freeside database to export to an ICRADIUS/FreeRADIUS MySQL database with this option. <blockquote><b>ADDITIONAL DEPRECATED FUNCTIONALITY</b> (instead use <a href="http://www.mysql.com/documentation/mysql/bychapter/manual_MySQL_Database_Administration.html#Replication">MySQL replication</a> or point icradius_secrets to the external database) - your <a href="ftp://ftp.cheapnet.net/pub/icradius">ICRADIUS</a> machines or <a href="http://www.freeradius.org/">FreeRADIUS</a> (with MySQL authentication) machines, one per line. Machines listed in this file will have the radcheck table exported to them. Each line should contain four items, separted by whitespace: machine name, MySQL database name, MySQL username, and MySQL password. For example: <CODE>"radius.isp.tld radius_db radius_user passw0rd"</CODE></blockquote>', + 'type' => [qw( checkbox textarea )], + }, + + { + 'key' => 'icradius_mysqldest', + 'section' => 'radius', + 'description' => '<b>DEPRECATED</b> (instead use <a href="http://www.mysql.com/documentation/mysql/bychapter/manual_MySQL_Database_Administration.html#Replication">MySQL replication</a> or point icradius_secrets to the external database) - Destination directory for the MySQL databases, on the ICRADIUS/FreeRADIUS machines. Defaults to "/usr/local/var/".', + 'type' => 'text', + }, + + { + 'key' => 'icradius_mysqlsource', + 'section' => 'radius', + 'description' => '<b>DEPRECATED</b> (instead use <a href="http://www.mysql.com/documentation/mysql/bychapter/manual_MySQL_Database_Administration.html#Replication">MySQL replication</a> or point icradius_secrets to the external database) - Source directory for for the MySQL radcheck table files, on the Freeside machine. Defaults to "/usr/local/var/freeside".', + 'type' => 'text', + }, + + { + 'key' => 'icradius_secrets', + 'section' => 'radius', + 'description' => 'Optionally specifies a database for ICRADIUS/FreeRADIUS export. Three lines: DBI data source, username and password.', + 'type' => 'textarea', + }, + + { + 'key' => 'invoice_from', + 'section' => 'required', + 'description' => 'Return address on email invoices', + 'type' => 'text', + }, + + { + 'key' => 'invoice_template', + 'section' => 'required', + 'description' => 'Required template file for invoices. See the <a href="../docs/billing.html">billing documentation</a> for details.', + 'type' => 'textarea', + }, + + { + 'key' => 'lpr', + 'section' => 'required', + 'description' => 'Print command for paper invoices, for example `lpr -h\'', + 'type' => 'text', + }, + + { + 'key' => 'maildisablecatchall', + 'section' => 'depreciated', + 'description' => '<b>DEPRECIATED</b>, now the default. Turning this option on used to disable the requirement that each virtual domain have a catch-all mailbox.', + 'type' => 'checkbox', + }, + + { + 'key' => 'money_char', + 'section' => '', + 'description' => 'Currency symbol - defaults to `$\'', + 'type' => 'text', + }, + + { + 'key' => 'mxmachines', + 'section' => 'BIND', + 'description' => 'MX entries for new domains, weight and machine, one per line, with trailing `.\'', + 'type' => 'textarea', + }, + + { + 'key' => 'nsmachines', + 'section' => 'BIND', + 'description' => 'NS nameservers for new domains, one per line, with trailing `.\'', + 'type' => 'textarea', + }, + + { + 'key' => 'nismachines', + 'section' => 'shell', + 'description' => 'Your NIS master (not slave master) machines, one per line. This enables export of `/etc/global/passwd\' and `/etc/global/shadow\'.', + 'type' => 'textarea', + }, + + { + 'key' => 'passwordmin', + 'section' => 'password', + 'description' => 'Minimum password length (default 6)', + 'type' => 'text', + }, + + { + 'key' => 'passwordmax', + 'section' => 'password', + 'description' => 'Maximum password length (default 8) (don\'t set this over 12 if you need to import or export crypt() passwords)', + 'type' => 'text', + }, + + { + 'key' => 'qmailmachines', + 'section' => 'mail', + 'description' => 'Your qmail machines, one per line. This enables export of `/var/qmail/control/virtualdomains\', `/var/qmail/control/recipientmap\', and `/var/qmail/control/rcpthosts\'. Setting this option (even if empty) also turns on user `.qmail-extension\' file maintenance in conjunction with the <b>shellmachine</b> option.', + 'type' => [qw( checkbox textarea )], + }, + + { + 'key' => 'radiusmachines', + 'section' => 'radius', + 'description' => 'Your RADIUS authentication machines, one per line. This enables export of `/etc/raddb/users\'.', + 'type' => 'textarea', + }, + + { + 'key' => 'referraldefault', + 'section' => 'UI', + 'description' => 'Default referral, specified by refnum', + 'type' => 'text', + }, + +# { +# 'key' => 'registries', +# 'section' => 'required', +# 'description' => 'Directory which contains domain registry information. Each registry is a directory.', +# }, + + { + 'key' => 'maxsearchrecordsperpage', + 'section' => 'UI', + 'description' => 'If set, number of search records to return per page.', + 'type' => 'text', + }, + + { + 'key' => 'sendmailconfigpath', + 'section' => 'mail', + 'description' => 'Sendmail configuration file path. Defaults to `/etc\'. Many newer distributions use `/etc/mail\'.', + 'type' => 'text', + }, + + { + 'key' => 'sendmailmachines', + 'section' => 'mail', + 'description' => 'Your sendmail machines, one per line. This enables export of `/etc/virtusertable\' and `/etc/sendmail.cw\'.', + 'type' => 'textarea', + }, + + { + 'key' => 'sendmailrestart', + 'section' => 'mail', + 'description' => 'If defined, the command which is run on sendmail machines after files are copied.', + 'type' => 'text', + }, + + { + 'key' => 'session-start', + 'section' => 'session', + 'description' => 'If defined, the command which is executed on the Freeside machine when a session begins. The contents of the file are treated as a double-quoted perl string, with the following variables available: <code>$ip</code>, <code>$nasip</code> and <code>$nasfqdn</code>, which are the IP address of the starting session, and the IP address and fully-qualified domain name of the NAS this session is on.', + 'type' => 'text', + }, + + { + 'key' => 'session-stop', + 'section' => 'session', + 'description' => 'If defined, the command which is executed on the Freeside machine when a session ends. The contents of the file are treated as a double-quoted perl string, with the following variables available: <code>$ip</code>, <code>$nasip</code> and <code>$nasfqdn</code>, which are the IP address of the starting session, and the IP address and fully-qualified domain name of the NAS this session is on.', + 'type' => 'text', + }, + + { + 'key' => 'shellmachine', + 'section' => 'shell', + 'description' => 'A single machine with user home directories mounted. This enables home directory creation, renaming and archiving/deletion. In conjunction with `qmailmachines\', it also enables `.qmail-extension\' file maintenance.', + 'type' => 'text', + }, + + { + 'key' => 'shellmachine-useradd', + 'section' => 'shell', + 'description' => 'The command(s) to run on shellmachine when an account is created. If the <b>shellmachine</b> option is set but this option is not, <code>useradd -d $dir -m -s $shell -u $uid $username</code> is the default. If this option is set but empty, <code>cp -pr /etc/skel $dir; chown -R $uid.$gid $dir</code> is the default instead. Otherwise the value is evaluated as a double-quoted perl string, with the following variables available: <code>$username</code>, <code>$uid</code>, <code>$gid</code>, <code>$dir</code>, and <code>$shell</code>.', + 'type' => [qw( checkbox text )], + }, + + { + 'key' => 'shellmachine-userdel', + 'section' => 'shell', + 'description' => 'The command(s) to run on shellmachine when an account is deleted. If the <b>shellmachine</b> option is set but this option is not, <code>userdel $username</code> is the default. If this option is set but empty, <code>rm -rf $dir</code> is the default instead. Otherwise the value is evaluated as a double-quoted perl string, with the following variables available: <code>$username</code> and <code>$dir</code>.', + 'type' => [qw( checkbox text )], + }, + + { + 'key' => 'shellmachine-usermod', + 'section' => 'shell', + 'description' => 'The command(s) to run on shellmachine when an account is modified. If the <b>shellmachine</b> option is set but this option is empty, <code>[ -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 )</code> is the default. Otherwise the contents of the file are treated as a double-quoted perl string, with the following variables available: <code>$old_dir</code>, <code>$new_dir</code>, <code>$uid</code> and <code>$gid</code>.', + #'type' => [qw( checkbox text )], + 'type' => 'text', + }, + + { + 'key' => 'shellmachines', + 'section' => 'shell', + 'description' => 'Your Linux and System V flavored shell (and mail) machines, one per line. This enables export of `/etc/passwd\' and `/etc/shadow\' files.', + 'type' => 'textarea', + }, + + { + 'key' => 'shells', + 'section' => 'required', + 'description' => 'Legal shells (think /etc/shells). You probably want to `cut -d: -f7 /etc/passwd | sort | uniq\' initially so that importing doesn\'t fail with `Illegal shell\' errors, then remove any special entries afterwords. A blank line specifies that an empty shell is permitted.', + 'type' => 'textarea', + }, + + { + 'key' => 'showpasswords', + 'section' => 'UI', + 'description' => 'Display unencrypted user passwords in the web interface', + 'type' => 'checkbox', + }, + + { + 'key' => 'signupurl', + 'section' => 'UI', + 'description' => 'if you are using customer-to-customer referrals, and you enter the URL of your <a href="../docs/signup.html">signup server CGI</a>, the customer view screen will display a customized link to the signup server with the appropriate customer as referral', + 'type' => 'text', + }, + + { + 'key' => 'smtpmachine', + 'section' => 'required', + 'description' => 'SMTP relay for Freeside\'s outgoing mail', + 'type' => 'text', + }, + + { + 'key' => 'soadefaultttl', + 'section' => 'BIND', + 'description' => 'SOA default TTL for new domains.', + 'type' => 'text', + }, + + { + 'key' => 'soaemail', + 'section' => 'BIND', + 'description' => 'SOA email for new domains, in BIND form (`.\' instead of `@\'), with trailing `.\'', + 'type' => 'text', + }, + + { + 'key' => 'soaexpire', + 'section' => 'BIND', + 'description' => 'SOA expire for new domains', + 'type' => 'text', + }, + + { + 'key' => 'soamachine', + 'section' => 'BIND', + 'description' => 'SOA machine for new domains, with trailing `.\'', + 'type' => 'text', + }, + + { + 'key' => 'soarefresh', + 'section' => 'BIND', + 'description' => 'SOA refresh for new domains', + 'type' => 'text', + }, + + { + 'key' => 'soaretry', + 'section' => 'BIND', + 'description' => 'SOA retry for new domains', + 'type' => 'text', + }, + + { + 'key' => 'statedefault', + 'section' => 'UI', + 'description' => 'Default state or province (if not supplied, the default is `CA\')', + 'type' => 'text', + }, + + { + 'key' => 'radiusprepend', + 'section' => 'radius', + 'description' => 'The contents will be prepended to the top of the RADIUS users file (text exports only).', + 'type' => 'textarea', + }, + + { + 'key' => 'textradiusprepend', + 'section' => 'depreciated', + 'description' => '<b>DEPRECIATED</b>, use RADIUS check attributes instead. This option will be removed soon. The contents will be prepended to the first line of a user\'s RADIUS entry in text exports.', + 'type' => 'text', + }, + + { + 'key' => 'unsuspendauto', + 'section' => 'billing', + 'description' => 'Enables the automatic unsuspension of suspended packages when a customer\'s balance due changes from positive to zero or negative as the result of a payment or credit', + 'type' => 'checkbox', + }, + + { + 'key' => 'usernamemin', + 'section' => 'username', + 'description' => 'Minimum username length (default 2)', + 'type' => 'text', + }, + + { + 'key' => 'usernamemax', + 'section' => 'username', + 'description' => 'Maximum username length', + 'type' => 'text', + }, + + { + 'key' => 'username-ampersand', + 'section' => 'username', + 'description' => 'Allow the ampersand character (&) in usernames. Be careful when using this option in conjunction with <a href="#shellmachine-useradd">shellmachine-useradd</a> and other configuration options which execute shell commands, as the ampersand will be interpreted by the shell if not quoted.', + 'type' => 'checkbox', + }, + + { + 'key' => 'username-letter', + 'section' => 'username', + 'description' => 'Usernames must contain at least one letter', + 'type' => 'checkbox', + }, + + { + 'key' => 'username-letterfirst', + 'section' => 'username', + 'description' => 'Usernames must start with a letter', + 'type' => 'checkbox', + }, + + { + 'key' => 'username-noperiod', + 'section' => 'username', + 'description' => 'Disallow periods in usernames', + 'type' => 'checkbox', + }, + + { + 'key' => 'username-uppercase', + 'section' => 'username', + 'description' => 'Allow uppercase characters in usernames', + 'type' => 'checkbox', + }, + + { + 'key' => 'username_policy', + 'section' => '', + 'description' => 'This file controls the mechanism for preventing duplicate usernames in passwd/radius files exported from svc_accts. This should be one of \'prepend domsvc\' \'append domsvc\' \'append domain\' or \'append @domain\'', + 'type' => 'select', + 'select_enum' => [ 'prepend domsvc', 'append domsvc', 'append domain', 'append @domain' ], + #'type' => 'text', + }, + + { + 'key' => 'vpopmailmachines', + 'section' => 'mail', + 'description' => 'Your vpopmail pop toasters, one per line. Each line is of the form "machinename vpopdir vpopuid vpopgid". For example: <code>poptoaster.domain.tld /home/vpopmail 508 508</code> Note: vpopuid and vpopgid are values taken from the vpopmail machine\'s /etc/passwd', + 'type' => 'textarea', + }, + + { + 'key' => 'vpopmailrestart', + 'section' => 'mail', + 'description' => 'If defined, the shell commands to run on vpopmail machines after files are copied. An example can be found in eg/vpopmailrestart of the source distribution.', + 'type' => 'textarea', + }, + + { + 'key' => 'safe-part_pkg', + 'section' => 'UI', + 'description' => 'Validates package definition setup and recur expressions against a preset list. Useful for webdemos, annoying to powerusers.', + 'type' => 'checkbox', + }, + + { + 'key' => 'safe-part_bill_event', + 'section' => 'UI', + 'description' => 'Validates invoice event expressions against a preset list. Useful for webdemos, annoying to powerusers.', + 'type' => 'checkbox', + }, + + { + 'key' => 'show_ss', + 'section' => 'UI', + 'description' => 'Turns on display/collection of SS# in the web interface.', + 'type' => 'checkbox', + }, + + { + 'key' => 'agent_defaultpkg', + 'section' => 'UI', + 'description' => 'Setting this option will cause new packages to be available to all agent types by default.', + 'type' => 'checkbox', + }, + + { + 'key' => 'legacy_link', + 'section' => 'UI', + 'description' => 'Display options in the web interface to link legacy pre-Freeside services.', + 'type' => 'checkbox', + }, + +); + +1; + diff --git a/FS/FS/ConfItem.pm b/FS/FS/ConfItem.pm new file mode 100644 index 000000000..83295b4fa --- /dev/null +++ b/FS/FS/ConfItem.pm @@ -0,0 +1,63 @@ +package FS::ConfItem; + +=head1 NAME + +FS::ConfItem - Configutaion option meta-data. + +=head1 SYNOPSIS + + use FS::Conf; + @config_items = $conf->config_items; + + foreach $item ( @config_items ) { + $key = $item->key; + $section = $item->section; + $description = $item->description; + } + +=head1 DESCRIPTION + +=head1 METHODS + +=over 4 + +=item new + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = @_ ? shift : {}; + bless ($self, $class); +} + +=item key + +=item section + +=item description + +=cut + +sub AUTOLOAD { + my $self = shift; + my $field = $AUTOLOAD; + $field =~ s/.*://; + $self->{$field}; +} + +=back + +=head1 BUGS + +Terse docs. + +=head1 SEE ALSO + +L<FS::Conf> + +=cut + +1; + diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm new file mode 100644 index 000000000..f30223351 --- /dev/null +++ b/FS/FS/Record.pm @@ -0,0 +1,1178 @@ +package FS::Record; + +use strict; +use vars qw( $dbdef_file $dbdef $setup_hack $AUTOLOAD @ISA @EXPORT_OK $DEBUG + $me ); +use subs qw(reload_dbdef); +use Exporter; +use Carp qw(carp cluck croak confess); +use File::CounterFile; +use Locale::Country; +use DBI qw(:sql_types); +use DBIx::DBSchema 0.19; +use FS::UID qw(dbh checkruid getotaker datasrc driver_name); +use FS::SearchCache; + +@ISA = qw(Exporter); +@EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef jsearch); + +$DEBUG = 0; +$me = '[FS::Record]'; + +#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; #deprecated + + $error = $record->delete; + #$error = $record->del; #deprecated + + $error = $new_record->replace($old_record); + #$error = $new_record->rep($old_record); #deprecated + + $value = $record->unique('column'); + + $error = $record->ut_float('column'); + $error = $record->ut_number('column'); + $error = $record->ut_numbern('column'); + $error = $record->ut_money('column'); + $error = $record->ut_text('column'); + $error = $record->ut_textn('column'); + $error = $record->ut_alpha('column'); + $error = $record->ut_alphan('column'); + $error = $record->ut_phonen('column'); + $error = $record->ut_anything('column'); + $error = $record->ut_name('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); + + unless ( defined ( $self->table ) ) { + $self->{'Table'} = shift; + carp "warning: FS::Record::new called with table name ". $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->_cache($hashref, shift) if $self->can('_cache') && @_; + + $self; +} + +sub new_or_cached { + 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; + my $cache = shift; + if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) { + my $obj = $cache->cache->{$hashref->{$cache->key}}; + $obj->_cache($hashref, $cache) if $obj->can('_cache'); + $obj; + } else { + $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache); + } + +} + +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, CACHE_OBJ + +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($stable, $record, $select, $extra_sql, $cache ) = @_; + #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table"; + #for jsearch + $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable"; + $stable = $1; + $select ||= '*'; + my $dbh = dbh; + + my $table = $cache ? $cache->table : $stable; + + my @fields = grep exists($record->{$_}), fields($table); + + my $statement = "SELECT $select FROM $stable"; + if ( @fields ) { + $statement .= ' WHERE '. join(' AND ', map { + + my $op = '='; + if ( ref($record->{$_}) ) { + $op = $record->{$_}{'op'} if $record->{$_}{'op'}; + $op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name !~ /^Pg$/i; + $record->{$_} = $record->{$_}{'value'} + } + + if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) { + if ( driver_name =~ /^Pg$/i ) { + qq-( $_ IS NULL OR $_ = '' )-; + } else { + qq-( $_ IS NULL OR $_ = "" )-; + } + } else { + "$_ $op ?"; + } + } @fields ); + } + $statement .= " $extra_sql" if defined($extra_sql); + + warn "[debug]$me $statement\n" if $DEBUG; + my $sth = $dbh->prepare($statement) + or croak "$dbh->errstr doing $statement"; + + my $bind = 1; + + foreach my $field ( + grep defined( $record->{$_} ) && $record->{$_} ne '', @fields + ) { + if ( $record->{$field} =~ /^\d+(\.\d+)?$/ + && $dbdef->table($table)->column($field)->type =~ /(int)/i + ) { + $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_INTEGER } ); + } else { + $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_VARCHAR } ); + } + } + +# $sth->execute( map $record->{$_}, +# grep defined( $record->{$_} ) && $record->{$_} ne '', @fields +# ) or croak "Error executing \"$statement\": ". $sth->errstr; + + $sth->execute or croak "Error executing \"$statement\": ". $sth->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 + if ( $cache ) { + map { + new_or_cached( "FS::$table", { %{$_} }, $cache ) + } @{$sth->fetchall_arrayref( {} )}; + } else { + 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 jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY + +Experimental JOINed search method. Using this method, you can execute a +single SELECT spanning multiple tables, and cache the results for subsequent +method calls. Interface will almost definately change in an incompatible +fashion. + +Arguments: + +=cut + +sub jsearch { + my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_; + my $cache = FS::SearchCache->new( $ptable, $pkey ); + my %saw; + ( $cache, + grep { !$saw{$_->getfield($pkey)}++ } + qsearch($table, $record, $select, $extra_sql, $cache ) + ); +} + +=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 + +# readable/safe +#sub AUTOLOAD { +# my($self,$value)=@_; +# my($field)=$AUTOLOAD; +# $field =~ s/.*://; +# if ( defined($value) ) { +# confess "errant AUTOLOAD $field for $self (arg $value)" +# unless $self->can('setfield'); +# $self->setfield($field,$value); +# } else { +# confess "errant AUTOLOAD $field for $self (no args)" +# unless $self->can('getfield'); +# $self->getfield($field); +# } +#} + +# efficient +sub AUTOLOAD { + my $field = $AUTOLOAD; + $field =~ s/.*://; + if ( defined($_[1]) ) { + $_[0]->setfield($field, $_[1]); + } else { + $_[0]->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)). + ")" + ; + warn "[debug]$me $statement\n" if $DEBUG; + 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 + ); + warn "[debug]$me $statement\n" if $DEBUG; + 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 ); + warn "[debug]$me $new ->replace $old\n" if $DEBUG; + + my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields; + unless ( @diff ) { + carp "[warning]$me $new -> replace $old: 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 ) + ) + ; + warn "[debug]$me $statement\n" if $DEBUG; + 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); + + 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 + + $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' || $country eq 'CA' ) { + $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 "warning: don't know how to check phone numbers for country $country"; + return $self->ut_textn($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); + ''; +} + +=item ut_name COLUMN + +Check/untaint proper names; allows alphanumerics, spaces and the following +punctuation: , . - ' + +May not be null. + +=cut + +sub ut_name { + my( $self, $field ) = @_; + $self->getfield($field) =~ /^([\w \,\.\-\']+)$/ + or return "Illegal (name) $field: ". $self->getfield($field); + $self->setfield($field,$1); + ''; +} + +=item ut_zip COLUMN + +Check/untaint zip codes. + +=cut + +sub ut_zip { + my( $self, $field, $country ) = @_; + if ( $country eq 'US' ) { + $self->getfield($field) =~ /\s*(\d{5}(\-\d{4})?)\s*$/ + or return "Illegal (zip) $field for country $country: ". + $self->getfield($field); + $self->setfield($field,$1); + } else { + $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/ + or return "Illegal (zip) $field: ". $self->getfield($field); + $self->setfield($field,$1); + } + ''; +} + +=item ut_country COLUMN + +Check/untaint country codes. Country names are changed to codes, if possible - +see L<Locale::Country>. + +=cut + +sub ut_country { + my( $self, $field ) = @_; + unless ( $self->getfield($field) =~ /^(\w\w)$/ ) { + if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/ + && country2code($1) ) { + $self->setfield($field,uc(country2code($1))); + } + } + $self->getfield($field) =~ /^(\w\w)$/ + or return "Illegal (country) $field: ". $self->getfield($field); + $self->setfield($field,uc($1)); + ''; +} + +=item ut_anything COLUMN + +Untaints arbitrary data. Be careful. + +=cut + +sub ut_anything { + my( $self, $field ) = @_; + $self->getfield($field) =~ /^(.*)$/s + or return "Illegal $field: ". $self->getfield($field); + $self->setfield($field,$1); + ''; +} + +=item ut_enum COLUMN CHOICES_ARRAYREF + +Check/untaint a column, supplying all possible choices, like the "enum" type. + +=cut + +sub ut_enum { + my( $self, $field, $choices ) = @_; + foreach my $choice ( @$choices ) { + if ( $self->getfield($field) eq $choice ) { + $self->setfield($choice); + return ''; + } + } + return "Illegal (enum) field $field: ". $self->getfield($field); +} + +=item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN + +Check/untaint a foreign column key. Call a regular ut_ method (like ut_number) +on the column first. + +=cut + +sub ut_foreign_key { + my( $self, $field, $table, $foreign ) = @_; + qsearchs($table, { $foreign => $self->getfield($field) }) + or return "Can't find $field ". $self->getfield($field). + " in $table.$foreign"; + ''; +} + +=item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN + +Like ut_foreign_key, except the null value is also allowed. + +=cut + +sub ut_foreign_keyn { + my( $self, $field, $table, $foreign ) = @_; + $self->getfield($field) + ? $self->ut_foreign_key($field, $table, $foreign) + : ''; +} + +=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); + confess "Unknown table $table" unless $table_obj; + $table_obj->columns; +} + +=back + +=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 + or die "can't load database schema from $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 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 only checks 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) + +ut_zip should take an optional country like ut_phone. + +=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/SearchCache.pm b/FS/FS/SearchCache.pm new file mode 100644 index 000000000..4218acfb6 --- /dev/null +++ b/FS/FS/SearchCache.pm @@ -0,0 +1,96 @@ +package FS::SearchCache; + +use strict; +use vars qw($DEBUG); +#use Carp qw(carp cluck croak confess); + +$DEBUG = 0; + +=head1 NAME + +FS::SearchCache - cache + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head1 METHODS + +=over 4 + +=item new + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my( $table, $key ) = @_; + warn "table $table\n" if $DEBUG > 1; + warn "key $key\n" if $DEBUG > 1; + my $self = { 'table' => $table, + 'key' => $key, + 'cache' => {}, + 'subcache' => {}, + }; + bless ($self, $class); + + $self; +} + +=item table + +=cut + +sub table { my $self = shift; $self->{table}; } + +=item key + +=cut + +sub key { my $self = shift; $self->{key}; } + +=item cache + +=cut + +sub cache { my $self = shift; $self->{cache}; } + +=item subcache + +=cut + +sub subcache { + my $self = shift; + my $col = shift; + my $table = shift; + my $keyval = shift; + if ( exists $self->{subcache}->{$col}->{$keyval} ) { + warn "returning existing subcache for $keyval ($col)". + "$self->{subcache}->{$col}->{$keyval}\n" if $DEBUG; + return $self->{subcache}->{$col}->{$keyval}; + } else { + #my $tablekey = @_ ? shift : $col; + my $tablekey = $col; + my $subcache = ref($self)->new( $table, $tablekey ); + $self->{subcache}->{$col}->{$keyval} = $subcache; + warn "creating new subcache $table $tablekey: $subcache\n" if $DEBUG; + $subcache; + } +} + +=back + +=head1 BUGS + +Dismal documentation. + +=head1 SEE ALSO + +L<FS::Record>, L<FS::cust_main> + +=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..d34d28e06 --- /dev/null +++ b/FS/FS/UID.pm @@ -0,0 +1,280 @@ +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 cgisuidsetup adminsuidsetup forksuidsetup + 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); + + 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 { + $dbh->disconnect if $dbh; + &forksuidsetup(@_); +} + +sub forksuidsetup { + $user = shift; + croak "fatal: adminsuidsetup called without arguements" unless $user; + + $user =~ /^([\w\-\.]+)$/ or croak "fatal: illegal user $user"; + $user = $1; + + $ENV{'PATH'} ='/usr/local/bin:/usr/bin:/usr/ucb:/bin'; + $ENV{'SHELL'} = '/bin/sh'; + $ENV{'IFS'} = " \t\n"; + $ENV{'CDPATH'} = ''; + $ENV{'ENV'} = ''; + $ENV{'BASH_ENV'} = ''; + + croak "Not running uid freeside!" unless checkeuid(); + getsecrets; + $dbh = DBI->connect($datasrc,$db_user,$db_pass, { + 'AutoCommit' => 0, + 'ChopBlanks' => 1, + } ) or die "DBI->connect error: $DBI::errstr\n"; + + 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 - you need to setup ". + "Apache user authentication as documented in httemplate/docs/install.html"; + } + $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 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 $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.14 2002-02-23 07:00:21 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..943c7b3ec --- /dev/null +++ b/FS/FS/cust_bill.pm @@ -0,0 +1,904 @@ +package FS::cust_bill; + +use strict; +use vars qw( @ISA $conf $invoice_template $money_char ); +use vars qw( $lpr $invoice_from $smtpmachine ); +use vars qw( $processor ); +use vars qw( $xaction $E_NoErr ); +use vars qw( $bop_processor $bop_login $bop_password $bop_action @bop_options ); +use vars qw( $invoice_lines @buf ); #yuck +use Date::Format; +use Mail::Internet; +use Mail::Header; +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; +use FS::cust_credit_bill; +use FS::cust_pay_batch; +use FS::cust_bill_event; + +@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"; + + $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('business-onlinepayment') ) { + ( $bop_processor, + $bop_login, + $bop_password, + $bop_action, + @bop_options + ) = $conf->config('business-onlinepayment'); + $bop_action ||= 'normal authorization'; + eval "use Business::OnlinePayment"; + $processor="Business::OnlinePayment::$bop_processor"; + } + +}; + +=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; + + $tax_amount = $record->tax; + + @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 - deprecated + +=item closed - books closed flag, empty or `Y' + +=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 { + my $self = shift; + return "Can't delete closed invoice" if $self->closed =~ /^Y/i; + $self->SUPER::delete(@_); +} + +=item replace OLD_RECORD + +Replaces the OLD_RECORD with this one in the database. If there is an error, +returns the error, otherwise returns false. + +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') + || $self->ut_enum('closed', [ '', 'Y' ]) + ; + 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_bill_event + +Returns the completed invoice events (see L<FS::cust_bill_event>) for this +invoice. + +=cut + +sub cust_bill_event { + my $self = shift; + qsearch( 'cust_bill_event', { 'invnum' => $self->invnum } ); +} + + +=item cust_main + +Returns the customer (see L<FS::cust_main>) for this invoice. + +=cut + +sub cust_main { + my $self = shift; + qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); +} + +=item cust_credit + +Depreciated. See the cust_credited method. + + #Returns a list consisting of the total previous credited (see + #L<FS::cust_credit>) and unapplied for this customer, followed by the previous + #outstanding credits (FS::cust_credit objects). + +=cut + +sub cust_credit { + use Carp; + croak "FS::cust_bill->cust_credit depreciated; see ". + "FS::cust_bill->cust_credit_bill"; + #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 + +Depreciated. See the cust_bill_pay method. + +#Returns all payments (see L<FS::cust_pay>) for this invoice. + +=cut + +sub cust_pay { + use Carp; + croak "FS::cust_bill->cust_pay depreciated; see FS::cust_bill->cust_bill_pay"; + #my $self = shift; + #sort { $a->_date <=> $b->_date } + # qsearch( 'cust_pay', { 'invnum' => $self->invnum } ) + #; +} + +=item cust_bill_pay + +Returns all payment applications (see L<FS::cust_bill_pay>) for this invoice. + +=cut + +sub cust_bill_pay { + my $self = shift; + sort { $a->_date <=> $b->_date } + qsearch( 'cust_bill_pay', { 'invnum' => $self->invnum } ); +} + +=item cust_credited + +Returns all applied credits (see L<FS::cust_credit_bill>) for this invoice. + +=cut + +sub cust_credited { + my $self = shift; + sort { $a->_date <=> $b->_date } + qsearch( 'cust_credit_bill', { 'invnum' => $self->invnum } ) + ; +} + +=item tax + +Returns the tax amount (see L<FS::cust_bill_pkg>) for this invoice. + +=cut + +sub tax { + my $self = shift; + my $total = 0; + my @taxlines = qsearch( 'cust_bill_pkg', { 'invnum' => $self->invnum , + 'pkgnum' => 0 } ); + foreach (@taxlines) { $total += $_->setup; } + $total; +} + +=item owed + +Returns the amount owed (still outstanding) on this invoice, which is charged +minus all payment applications (see L<FS::cust_bill_pay>) and credit +applications (see L<FS::cust_credit_bill>). + +=cut + +sub owed { + my $self = shift; + my $balance = $self->charged; + $balance -= $_->amount foreach ( $self->cust_bill_pay ); + $balance -= $_->amount foreach ( $self->cust_credited ); + $balance = sprintf( "%.2f", $balance); + $balance =~ s/^\-0\.00$/0.00/; #yay ieee fp + $balance; +} + +=item send + +Sends this invoice to the destinations configured for this customer: send +emails or print. See L<FS::cust_main_invoice>. + +=cut + +sub send { + my $self = shift; + + #my @print_text = $cust_bill->print_text; #( date ) + my @invoicing_list = $self->cust_main->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' => [ $self->print_text ], #( date) + ); + $message->smtpsend + or return "(customer # ". $self->custnum. ") can't send invoice email". + " for ". join(', ', grep { $_ ne 'POST' } @invoicing_list ). + " to server $smtpmachine!"; + + #} elsif ( grep { $_ eq 'POST' } @invoicing_list ) { + } elsif ( ! @invoicing_list || grep { $_ eq 'POST' } @invoicing_list ) { + open(LPR, "|$lpr") + or return "Can't open pipe to $lpr: $!"; + print LPR $self->print_text; #( date ) + close LPR + or return $! ? "Error closing $lpr: $!" + : "Exit status $? from $lpr"; + } + + ''; + +} + +=item comp + +Pays this invoice with a compliemntary payment. If there is an error, +returns the error, otherwise returns false. + +=cut + +sub comp { + my $self = shift; + my $cust_pay = new FS::cust_pay ( { + 'invnum' => $self->invnum, + 'paid' => $self->owed, + '_date' => '', + 'payby' => 'COMP', + 'payinfo' => $self->cust_main->payinfo, + 'paybatch' => '', + } ); + $cust_pay->insert; +} + +=item realtime_card + +Attempts to pay this invoice with a Business::OnlinePayment realtime gateway. +See http://search.cpan.org/search?mode=module&query=Business%3A%3AOnlinePayment +for supproted processors. + +=cut + +sub realtime_card { + my $self = shift; + my $cust_main = $self->cust_main; + my $amount = $self->owed; + + unless ( $processor =~ /^Business::OnlinePayment::(.*)$/ ) { + return "Real-time card processing not enabled (processor $processor)"; + } + my $bop_processor = $1; #hmm? + + my $address = $cust_main->address1; + $address .= ", ". $cust_main->address2 if $cust_main->address2; + + #fix exp. date + #$cust_main->paydate =~ /^(\d+)\/\d*(\d{2})$/; + $cust_main->paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/; + my $exp = "$2/$1"; + + my($payname, $payfirst, $paylast); + if ( $cust_main->payname ) { + $payname = $cust_main->payname; + $payname =~ /^\s*([\w \,\.\-\']*\w)?\s+([\w\,\.\-\']+)$/ + or do { + #$dbh->rollback if $oldAutoCommit; + return "Illegal payname $payname"; + }; + ($payfirst, $paylast) = ($1, $2); + } else { + $payfirst = $cust_main->getfield('first'); + $paylast = $cust_main->getfield('first'); + $payname = "$payfirst $paylast"; + } + + my @invoicing_list = grep { $_ ne 'POST' } $cust_main->invoicing_list; + if ( $conf->exists('emailinvoiceauto') + || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) { + push @invoicing_list, $cust_main->default_invoicing_list; + } + my $email = $invoicing_list[0]; + + my( $action1, $action2 ) = split(/\s*\,\s*/, $bop_action ); + + my $transaction = + new Business::OnlinePayment( $bop_processor, @bop_options ); + $transaction->content( + 'type' => 'CC', + 'login' => $bop_login, + 'password' => $bop_password, + 'action' => $action1, + 'description' => 'Internet Services', + 'amount' => $amount, + 'invoice_number' => $self->invnum, + 'customer_id' => $self->custnum, + 'last_name' => $paylast, + 'first_name' => $payfirst, + 'name' => $payname, + 'address' => $address, + 'city' => $cust_main->city, + 'state' => $cust_main->state, + 'zip' => $cust_main->zip, + 'country' => $cust_main->country, + 'card_number' => $cust_main->payinfo, + 'expiration' => $exp, + 'referer' => 'http://cleanwhisker.420.am/', + 'email' => $email, + ); + $transaction->submit(); + + if ( $transaction->is_success() && $action2 ) { + my $auth = $transaction->authorization; + my $ordernum = $transaction->order_number; + #warn "********* $auth ***********\n"; + #warn "********* $ordernum ***********\n"; + my $capture = + new Business::OnlinePayment( $bop_processor, @bop_options ); + + $capture->content( + action => $action2, + login => $bop_login, + password => $bop_password, + order_number => $ordernum, + amount => $amount, + authorization => $auth, + description => 'Internet Services', + ); + + $capture->submit(); + + unless ( $capture->is_success ) { + my $e = "Authorization sucessful but capture failed, invnum #". + $self->invnum. ': '. $capture->result_code. + ": ". $capture->error_message; + warn $e; + return $e; + } + + } + + if ( $transaction->is_success() ) { + + my $cust_pay = new FS::cust_pay ( { + 'invnum' => $self->invnum, + 'paid' => $amount, + '_date' => '', + 'payby' => 'CARD', + 'payinfo' => $cust_main->payinfo, + 'paybatch' => "$processor:". $transaction->authorization, + } ); + my $error = $cust_pay->insert; + if ( $error ) { + # gah, even with transactions. + my $e = 'WARNING: Card debited but database not updated - '. + 'error applying payment, invnum #' . $self->invnum. + " ($processor): $error"; + warn $e; + return $e; + } else { + return ''; + } + #} elsif ( $options{'report_badcard'} ) { + } else { + return "$processor error, invnum #". $self->invnum. ': '. + $transaction->result_code. ": ". $transaction->error_message; + } + +} + +=item realtime_card_cybercash + +Attempts to pay this invoice with the CyberCash CashRegister realtime gateway. + +=cut + +sub realtime_card_cybercash { + my $self = shift; + my $cust_main = $self->cust_main; + my $amount = $self->owed; + + return "CyberCash CashRegister real-time card processing not enabled!" + unless $processor eq 'cybercash3.2'; + + my $address = $cust_main->address1; + $address .= ", ". $cust_main->address2 if $cust_main->address2; + + #fix exp. date + #$cust_main->paydate =~ /^(\d+)\/\d*(\d{2})$/; + $cust_main->paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/; + my $exp = "$2/$1"; + + # + + my $paybatch = $self->invnum. + '-' . time2str("%y%m%d%H%M%S", time); + + my $payname = $cust_main->payname || + $cust_main->getfield('first').' '.$cust_main->getfield('last'); + + my $country = $cust_main->country eq 'US' ? 'USA' : $cust_main->country; + + my @full_xaction = ( $xaction, + 'Order-ID' => $paybatch, + 'Amount' => "usd $amount", + 'Card-Number' => $cust_main->getfield('payinfo'), + 'Card-Name' => $payname, + 'Card-Address' => $address, + 'Card-City' => $cust_main->getfield('city'), + 'Card-State' => $cust_main->getfield('state'), + 'Card-Zip' => $cust_main->getfield('zip'), + 'Card-Country' => $country, + 'Card-Exp' => $exp, + ); + + my %result; + %result = &CCMckDirectLib3_2::SendCC2_1Server(@full_xaction); + + if ( $result{'MStatus'} eq 'success' ) { #cybercash smps v.2 or 3 + my $cust_pay = new FS::cust_pay ( { + 'invnum' => $self->invnum, + 'paid' => $amount, + '_date' => '', + 'payby' => 'CARD', + 'payinfo' => $cust_main->payinfo, + 'paybatch' => "$processor:$paybatch", + } ); + my $error = $cust_pay->insert; + if ( $error ) { + # gah, even with transactions. + my $e = 'WARNING: Card debited but database not updated - '. + 'error applying payment, invnum #' . $self->invnum. + " (CyberCash Order-ID $paybatch): $error"; + warn $e; + return $e; + } else { + return ''; + } +# } elsif ( $result{'Mstatus'} ne 'failure-bad-money' +# || $options{'report_badcard'} +# ) { + } else { + return 'Cybercash error, invnum #' . + $self->invnum. ':'. $result{'MErrMsg'}; + } + +} + +=item batch_card + +Adds a payment for this invoice to the pending credit card batch (see +L<FS::cust_pay_batch>). + +=cut + +sub batch_card { + my $self = shift; + my $cust_main = $self->cust_main; + + my $cust_pay_batch = new FS::cust_pay_batch ( { + 'invnum' => $self->getfield('invnum'), + 'custnum' => $cust_main->getfield('custnum'), + 'last' => $cust_main->getfield('last'), + 'first' => $cust_main->getfield('first'), + 'address1' => $cust_main->getfield('address1'), + 'address2' => $cust_main->getfield('address2'), + 'city' => $cust_main->getfield('city'), + 'state' => $cust_main->getfield('state'), + 'zip' => $cust_main->getfield('zip'), + 'country' => $cust_main->getfield('country'), + 'trancode' => 77, + 'cardnum' => $cust_main->getfield('payinfo'), + 'exp' => $cust_main->getfield('paydate'), + 'payname' => $cust_main->getfield('payname'), + 'amount' => $self->owed, + } ); + $cust_pay_batch->insert; + +} + +=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 $balance_due = $self->owed + $pr_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 ( $self->cust_credited ) { + + #something more elaborate if $_->amount ne $_->cust_credit->credited ? + + my $reason = substr($_->cust_credit->reason,0,32); + $reason .= '...' if length($reason) < length($_->cust_credit->reason); + $reason = " ($reason) " if $reason; + push @buf,[ + "Credit #". $_->crednum. " (". time2str("%x",$_->cust_credit->_date) .")". + $reason, + $money_char. sprintf("%10.2f",$_->amount) + ]; + } + #foreach ( @cr_cust_credit ) { + # push @buf,[ + # "Credit #". $_->crednum. " (" . time2str("%x",$_->_date) .")", + # $money_char. sprintf("%10.2f",$_->credited) + # ]; + #} + + #get & print payments + foreach ( $self->cust_bill_pay ) { + + #something more elaborate if $_->amount ne ->cust_pay->paid ? + + push @buf,[ + "Payment received ". time2str("%x",$_->cust_pay->_date ), + $money_char. sprintf("%10.2f",$_->amount ) + ]; + } + + #balance due + push @buf,['','-----------']; + push @buf,['Balance Due', $money_char. + sprintf("%10.2f", $balance_due ) ]; + + #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.19 2002-02-12 18:56:16 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_bill_pay>, L<FS::cust_pay>, +L<FS::cust_bill_pkg>, L<FS::cust_bill_credit>, schema.html from the base +documentation. + +=cut + +1; + diff --git a/FS/FS/cust_bill_event.pm b/FS/FS/cust_bill_event.pm new file mode 100644 index 000000000..cc9ce7cb8 --- /dev/null +++ b/FS/FS/cust_bill_event.pm @@ -0,0 +1,147 @@ +package FS::cust_bill_event; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); +use FS::part_bill_event; + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::cust_bill_event - Object methods for cust_bill_event records + +=head1 SYNOPSIS + + use FS::cust_bill_event; + + $record = new FS::cust_bill_event \%hash; + $record = new FS::cust_bill_event { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::cust_bill_event object represents an complete invoice event. +FS::cust_bill_event inherits from FS::Record. The following fields are +currently supported: + +=over 4 + +=item eventnum - primary key + +=item invnum - invoice (see L<FS::cust_bill>) + +=item eventpart - event definition (see L<FS::part_bill_event>) + +=item _date - specified as a UNIX timestamp; see L<perlfunc/"time">. Also see +L<Time::Local> and L<Date::Parse> for conversion functions. + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new completed invoice event. To add the compelted invoice event 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 { 'cust_bill_event'; } + +=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 completed invoice event. 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('eventnum') + || $self->ut_number('invnum') + || $self->ut_number('eventpart') + || $self->ut_number('_date') + ; + + return "Unknown invnum" + unless qsearchs( 'cust_bill' ,{ 'invnum' => $self->invnum } ); + + return "Unknown eventpart" + unless qsearchs( 'part_bill_event' ,{ 'eventpart' => $self->eventpart } ); + + ''; #no error +} + +=item part_bill_event + +Returns the invoice event definition (see L<FS::part_bill_event>) for this +completed invoice event. + +=cut + +sub part_bill_event { + my $self = shift; + qsearchs( 'part_bill_event', { 'eventpart' => $self->eventpart } ); +} + +=back + +=head1 BUGS + +Far too early in the morning. + +=head1 SEE ALSO + +L<FS::part_bill_event>, L<FS::cust_bill>, L<FS::Record>, schema.html from the +base documentation. + +=cut + +1; + diff --git a/FS/FS/cust_bill_pay.pm b/FS/FS/cust_bill_pay.pm new file mode 100644 index 000000000..913704bef --- /dev/null +++ b/FS/FS/cust_bill_pay.pm @@ -0,0 +1,219 @@ +package FS::cust_bill_pay; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs dbh ); +use FS::cust_bill; +use FS::cust_pay; + +@ISA = qw( FS::Record ); + +=head1 NAME + +FS::cust_bill_pay - Object methods for cust_bill_pay records + +=head1 SYNOPSIS + + use FS::cust_bill_pay; + + $record = new FS::cust_bill_pay \%hash; + $record = new FS::cust_bill_pay { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::cust_bill_pay object represents the application of a payment to a +specific invoice. FS::cust_bill_pay inherits from FS::Record. The following +fields are currently supported: + +=over 4 + +=item billpaynum - primary key (assigned automatically) + +=item invnum - Invoice (see L<FS::cust_bill>) + +=item paynum - Payment (see L<FS::cust_pay>) + +=item amount - Amount of the payment to apply to the specific invoice. + +=item _date - specified as a UNIX timestamp; see L<perlfunc/"time">. Also see +L<Time::Local> and L<Date::Parse> for conversion functions. + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new record. To add the record to the database, see L<"insert">. + +=cut + +sub table { 'cust_bill_pay'; } + +=item insert + +Adds this record to the database. If there is an error, returns the error, +otherwise returns false. + +=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 $error = $self->check; + return $error if $error; + + $error = $self->SUPER::insert; + + my $cust_pay = qsearchs('cust_pay', { 'paynum' => $self->paynum } ) or do { + $dbh->rollback if $oldAutoCommit; + return "unknown cust_pay.paynum: ". $self->paynum; + }; + + my $pay_total = 0; + $pay_total += $_ foreach map { $_->amount } + qsearch('cust_bill_pay', { 'paynum' => $self->paynum } ); + + if ( sprintf("%.2f", $pay_total) > sprintf("%.2f", $cust_pay->paid) ) { + $dbh->rollback if $oldAutoCommit; + return "total cust_bill_pay.amount $pay_total for paynum ". $self->paynum. + " greater than cust_pay.paid ". $cust_pay->paid; + } + + my $cust_bill = qsearchs('cust_bill', { 'invnum' => $self->invnum } ) or do { + $dbh->rollback if $oldAutoCommit; + return "unknown cust_bill.invnum: ". $self->invnum; + }; + + my $bill_total = 0; + $bill_total += $_ foreach map { $_->amount } + qsearch('cust_bill_pay', { 'invnum' => $self->invnum } ); + $bill_total += $_ foreach map { $_->amount } + qsearch('cust_credit_bill', { 'invnum' => $self->invnum } ); + if ( sprintf("%.2f", $bill_total) > sprintf("%.2f", $cust_bill->charged) ) { + $dbh->rollback if $oldAutoCommit; + return "total cust_bill_pay.amount and cust_credit_bill.amount $bill_total". + " for invnum ". $self->invnum. + " greater than cust_bill.charged ". $cust_bill->charged; + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; +} + +=item delete + +Deletes this payment application, unless the closed flag for the parent payment +(see L<FS::cust_pay>) is set. + +=cut + +sub delete { + my $self = shift; + return "Can't delete application for closed payment" + if $self->cust_pay->closed =~ /^Y/i; + $self->SUPER::delete(@_); +} + +=item replace OLD_RECORD + +Currently unimplemented (accounting reasons). + +=cut + +sub replace { + return "Can't (yet?) modify cust_bill_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 = + $self->ut_numbern('billpaynum') + || $self->ut_number('invnum') + || $self->ut_number('paynum') + || $self->ut_money('amount') + || $self->ut_numbern('_date') + ; + return $error if $error; + + return "amount must be > 0" if $self->amount <= 0; + + $self->_date(time) unless $self->_date; + + ''; #no error +} + +=item cust_pay + +Returns the payment (see L<FS::cust_pay>) + +=cut + +sub cust_pay { + my $self = shift; + qsearchs( 'cust_pay', { 'paynum' => $self->paynum } ); +} + +=item cust_bill + +Returns the invoice (see L<FS::cust_bill>) + +=cut + +sub cust_bill { + my $self = shift; + qsearchs( 'cust_bill', { 'invnum' => $self->invnum } ); +} + +=back + +=head1 VERSION + +$Id: cust_bill_pay.pm,v 1.12 2002-02-07 22:29:34 ivan Exp $ + +=head1 BUGS + +Delete and replace methods. + +the checks for over-applied payments could be better done like the ones in +cust_bill_credit + +=head1 SEE ALSO + +L<FS::cust_pay>, L<FS::cust_bill>, L<FS::Record>, 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..0ce5ac614 --- /dev/null +++ b/FS/FS/cust_credit.pm @@ -0,0 +1,260 @@ +package FS::cust_credit; + +use strict; +use vars qw( @ISA $conf $unsuspendauto ); +use FS::UID qw( dbh getotaker ); +use FS::Record qw( qsearch qsearchs ); +use FS::cust_main; +use FS::cust_refund; +use FS::cust_credit_bill; + +@ISA = qw( FS::Record ); + +#ask FS::UID to run this stuff for us later +$FS::UID::callback{'FS::cust_credit'} = sub { + + $conf = new FS::Conf; + $unsuspendauto = $conf->exists('unsuspendauto'); + +}; + +=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 + +=item closed - books closed flag, empty or `Y' + +=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. + +=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 $cust_main = qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); + my $old_balance = $cust_main->balance; + + my $error = $self->SUPER::insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "error inserting $self: $error"; + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + #false laziness w/ cust_credit::insert + if ( $unsuspendauto && $old_balance && $cust_main->balance <= 0 ) { + my @errors = $cust_main->unsuspend; + #return + # side-fx with nested transactions? upstack rolls back? + warn "WARNING:Errors unsuspending customer ". $cust_main->custnum. ": ". + join(' / ', @errors) + if @errors; + } + #eslaf + + ''; + +} + +=item delete + +Currently unimplemented. + +=cut + +sub delete { + my $self = shift; + return "Can't delete closed credit" if $self->closed =~ /^Y/i; + $self->SUPER::delete(@_); +} + +=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') + || $self->ut_enum('closed', [ '', 'Y' ]) + ; + return $error if $error; + + return "amount must be > 0 " if $self->amount <= 0; + + return "Unknown customer" + unless qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); + + $self->_date(time) unless $self->_date; + + $self->otaker(getotaker); + + ''; #no error +} + +=item cust_refund + +Depreciated. See the cust_credit_refund method. + +#Returns all refunds (see L<FS::cust_refund>) for this credit. + +=cut + +sub cust_refund { + use Carp; + croak "FS::cust_credit->cust_pay depreciated; see ". + "FS::cust_credit->cust_credit_refund"; + #my $self = shift; + #sort { $a->_date <=> $b->_date } + # qsearch( 'cust_refund', { 'crednum' => $self->crednum } ) + #; +} + +=item cust_credit_refund + +Returns all refund applications (see L<FS::cust_credit_refund>) for this credit. + +=cut + +sub cust_credit_refund { + my $self = shift; + sort { $a->_date <=> $b->_date } + qsearch( 'cust_credit_refund', { 'crednum' => $self->crednum } ) + ; +} + +=item cust_credit_bill + +Returns all application to invoices (see L<FS::cust_credit_bill>) for this +credit. + +=cut + +sub cust_credit_bill { + my $self = shift; + sort { $a->_date <=> $b->_date } + qsearch( 'cust_credit_bill', { 'crednum' => $self->crednum } ) + ; +} + +=item credited + +Returns the amount of this credit that is still outstanding; which is +amount minus all refund applications (see L<FS::cust_credit_refund>) and +applications to invoices (see L<FS::cust_credit_bill>). + +=cut + +sub credited { + my $self = shift; + my $amount = $self->amount; + $amount -= $_->amount foreach ( $self->cust_credit_refund ); + $amount -= $_->amount foreach ( $self->cust_credit_bill ); + sprintf( "%.2f", $amount ); +} + +=back + +=head1 VERSION + +$Id: cust_credit.pm,v 1.15 2002-01-28 06:57:23 ivan Exp $ + +=head1 BUGS + +The delete method. + +=head1 SEE ALSO + +L<FS::Record>, L<FS::cust_credit_refund>, L<FS::cust_refund>, +L<FS::cust_credit_bill> L<FS::cust_bill>, schema.html from the base +documentation. + +=cut + +1; + diff --git a/FS/FS/cust_credit_bill.pm b/FS/FS/cust_credit_bill.pm new file mode 100644 index 000000000..62215419c --- /dev/null +++ b/FS/FS/cust_credit_bill.pm @@ -0,0 +1,162 @@ +package FS::cust_credit_bill; + +use strict; +use vars qw( @ISA ); +use FS::UID qw( getotaker ); +use FS::Record qw( qsearch qsearchs ); +use FS::cust_main; +#use FS::cust_refund; +use FS::cust_credit; +use FS::cust_bill; + +@ISA = qw( FS::Record ); + +=head1 NAME + +FS::cust_credit_bill - Object methods for cust_credit_bill records + +=head1 SYNOPSIS + + use FS::cust_credit_bill; + + $record = new FS::cust_credit_bill \%hash; + $record = new FS::cust_credit_bill { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::cust_credit_bill object represents application of a credit (see +L<FS::cust_credit>) to an invoice (see L<FS::cust_bill>). FS::cust_credit +inherits from FS::Record. The following fields are currently supported: + +=over 4 + +=item creditbillnum - primary key + +=item crednum - credit being applied + +=item invnum - invoice to which credit is applied (see L<FS::cust_bill>) + +=item amount - amount of the credit applied + +=item _date - specified as a UNIX timestamp; see L<perlfunc/"time">. Also see +L<Time::Local> and L<Date::Parse> for conversion functions. + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new cust_credit_bill. To add the cust_credit_bill to the database, +see L<"insert">. + +=cut + +sub table { 'cust_credit_bill'; } + +=item insert + +Adds this cust_credit_bill to the database ("Posts" all or part of a credit). +If there is an error, returns the error, otherwise returns false. + +=item delete + +Currently unimplemented. + +=cut + +sub delete { + return "Can't unapply credit!" +} + +=item replace OLD_RECORD + +Application of credits may not be modified. + +=cut + +sub replace { + return "Can't modify application of credit!" +} + +=item check + +Checks all fields to make sure this is a valid credit application. 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('creditbillnum') + || $self->ut_number('crednum') + || $self->ut_number('invnum') + || $self->ut_numbern('_date') + || $self->ut_money('amount') + ; + return $error if $error; + + return "amount must be > 0" if $self->amount <= 0; + + return "Unknown credit" + unless my $cust_credit = + qsearchs( 'cust_credit', { 'crednum' => $self->crednum } ); + + return "Unknown invoice" + unless my $cust_bill = + qsearchs( 'cust_bill', { 'invnum' => $self->invnum } ); + + $self->_date(time) unless $self->_date; + + return "Cannot apply more than remaining value of credit" + unless $self->amount <= $cust_credit->credited; + + return "Cannot apply more than remaining value of invoice" + unless $self->amount <= $cust_bill->owed; + + ''; #no error +} + +=item sub cust_credit + +Returns the credit (see L<FS::cust_credit>) + +=cut + +sub cust_credit { + my $self = shift; + qsearchs( 'cust_credit', { 'crednum' => $self->crednum } ); +} + +=back + +=head1 VERSION + +$Id: cust_credit_bill.pm,v 1.7 2002-01-24 16:58:47 ivan Exp $ + +=head1 BUGS + +The delete method. + +=head1 SEE ALSO + +L<FS::Record>, L<FS::cust_refund>, L<FS::cust_bill>, L<FS::cust_credit>, +schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/cust_credit_refund.pm b/FS/FS/cust_credit_refund.pm new file mode 100644 index 000000000..cc3b32cdb --- /dev/null +++ b/FS/FS/cust_credit_refund.pm @@ -0,0 +1,205 @@ +package FS::cust_credit_refund; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs dbh ); +#use FS::UID qw(getotaker); +use FS::cust_credit; +use FS::cust_refund; + +@ISA = qw( FS::Record ); + +=head1 NAME + +FS::cust_credit_refund - Object methods for cust_bill_pay records + +=head1 SYNOPSIS + + use FS::cust_credit_refund; + + $record = new FS::cust_credit_refund \%hash; + $record = new FS::cust_credit_refund { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::cust_credit_refund represents the application of a refund to a specific +credit. FS::cust_credit_refund inherits from FS::Record. The following fields +are currently supported: + +=over 4 + +=item creditrefundnum - primary key (assigned automatically) + +=item crednum - Credit (see L<FS::cust_credit>) + +=item refundnum - Refund (see L<FS::cust_refund>) + +=item amount - Amount of the refund to apply to the specific credit. + +=item _date - specified as a UNIX timestamp; see L<perlfunc/"time">. Also see +L<Time::Local> and L<Date::Parse> for conversion functions. + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new record. To add the record to the database, see L<"insert">. + +=cut + +sub table { 'cust_credit_refund'; } + +=item insert + +Adds this record to the database. If there is an error, returns the error, +otherwise returns false. + +=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 $error = $self->check; + return $error if $error; + + $error = $self->SUPER::insert; + + my $cust_refund = + qsearchs('cust_refund', { 'refundnum' => $self->refundnum } ) + or do { + $dbh->rollback if $oldAutoCommit; + return "unknown cust_refund.refundnum: ". $self->refundnum + }; + + my $refund_total = 0; + $refund_total += $_ foreach map { $_->amount } + qsearch('cust_credit_refund', { 'refundnum' => $self->refundnum } ); + + if ( $refund_total > $cust_refund->refund ) { + $dbh->rollback if $oldAutoCommit; + return "total cust_credit_refund.amount $refund_total for refundnum ". + $self->refundnum. + " greater than cust_refund.refund ". $cust_refund->refund; + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; +} + +=item delete + +Currently unimplemented (accounting reasons). + +=cut + +sub delete { + return "Can't (yet?) delete cust_credit_refund records!"; +} + +=item replace OLD_RECORD + +Currently unimplemented (accounting reasons). + +=cut + +sub replace { + return "Can't (yet?) modify cust_credit_refund 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 = + $self->ut_numbern('creditrefundnum') + || $self->ut_number('crednum') + || $self->ut_number('refundnum') + || $self->ut_money('amount') + || $self->ut_numbern('_date') + ; + return $error if $error; + + return "amount must be > 0" if $self->amount <= 0; + + $self->_date(time) unless $self->_date; + + return "unknown cust_credit.crednum: ". $self->crednum + unless qsearchs( 'cust_credit', { 'crednum' => $self->crednum } ); + + ''; #no error +} + +=item cust_refund + +Returns the refund (see L<FS::cust_refund>) + +=cut + +sub cust_refund { + my $self = shift; + qsearchs( 'cust_refund', { 'refundnum' => $self->refundnum } ); +} + +=item cust_credit + +Returns the credit (see L<FS::cust_credit>) + +=cut + +sub cust_credit { + my $self = shift; + qsearchs( 'cust_credit', { 'crednum' => $self->crednum } ); +} + +=back + +=head1 VERSION + +$Id: cust_credit_refund.pm,v 1.9 2002-01-26 01:52:31 ivan Exp $ + +=head1 BUGS + +Delete and replace methods. + +the checks for over-applied refunds could be better done like the ones in +cust_bill_credit + +=head1 SEE ALSO + +L<FS::cust_credit>, L<FS::cust_refund>, L<FS::Record>, 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..67b426b85 --- /dev/null +++ b/FS/FS/cust_main.pm @@ -0,0 +1,1762 @@ +package FS::cust_main; + +use strict; +use vars qw( @ISA $conf $Debug $import ); +use Safe; +use Carp; +use Time::Local; +use Date::Format; +#use Date::Manip; +use Business::CreditCard; +use FS::UID qw( getotaker dbh ); +use FS::Record qw( qsearchs qsearch dbdef ); +use FS::cust_pkg; +use FS::cust_bill; +use FS::cust_bill_pkg; +use FS::cust_pay; +use FS::cust_credit; +use FS::part_referral; +use FS::cust_main_county; +use FS::agent; +use FS::cust_main_invoice; +use FS::cust_credit_bill; +use FS::cust_bill_pay; +use FS::prepay_credit; +use FS::queue; +use FS::part_pkg; +use FS::part_bill_event; +use FS::cust_bill_event; + +@ISA = qw( FS::Record ); + +$Debug = 0; +#$Debug = 1; + +$import = 0; + +#ask FS::UID to run this stuff for us later +$FS::UID::callback{'FS::cust_main'} = sub { + $conf = new FS::Conf; + #yes, need it for stuff below (prolly should be cached) +}; + +sub _cache { + my $self = shift; + my ( $hashref, $cache ) = @_; + if ( exists $hashref->{'pkgnum'} ) { +# #@{ $self->{'_pkgnum'} } = (); + my $subcache = $cache->subcache( 'pkgnum', 'cust_pkg', $hashref->{custnum}); + $self->{'_pkgnum'} = $subcache; + #push @{ $self->{'_pkgnum'} }, + FS::cust_pkg->new_or_cached($hashref, $subcache) if $hashref->{pkgnum}; + } +} + +=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; + + @cust_pkg = $record->suspended_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 ship_first - name + +=item ship_last - name + +=item ship_company - (optional) + +=item ship_address1 + +=item ship_address2 - (optional) + +=item ship_city + +=item ship_county - (optional, see L<FS::cust_main_county>) + +=item ship_state - (see L<FS::cust_main_county>) + +=item ship_zip + +=item ship_country - (see L<FS::cust_main_county>) + +=item ship_daytime - phone (optional) + +=item ship_night - phone (optional) + +=item ship_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>) + +=item comments - comments (optional) + +=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 [ CUST_PKG_HASHREF [ , INVOICING_LIST_ARYREF ] ] + +Adds this customer to the database. If there is an error, returns the error, +otherwise returns false. + +CUST_PKG_HASHREF: If you pass a Tie::RefHash data structure to the insert +method containing FS::cust_pkg and FS::svc_I<tablename> objects, all records +are inserted atomicly, or the transaction is rolled back. Passing an empty +hash reference is equivalent to not supplying this parameter. 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 ); + +INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will +be set as the invoicing list (see L<"invoicing_list">). Errors return as +expected and rollback the entire transaction; it is not necessary to call +check_invoicing_list first. The invoicing_list is set after the records in the +CUST_PKG_HASHREF above are inserted, so it is now possible to set an +invoicing_list destination to the newly-created svc_acct. Here's an example: + + $cust_main->insert( {}, [ $email, 'POST' ] ); + +=cut + +sub insert { + my $self = shift; + my @param = @_; + + 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 "removing prepay_credit (transaction rolled back): $error"; + } + } + + my $error = $self->SUPER::insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "inserting cust_main record (transaction rolled back): $error"; + } + + if ( @param ) { # CUST_PKG_HASHREF + my $cust_pkgs = shift @param; + foreach my $cust_pkg ( keys %$cust_pkgs ) { + $cust_pkg->custnum( $self->custnum ); + $error = $cust_pkg->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "inserting cust_pkg (transaction rolled back): $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 "inserting svc_ (transaction rolled back): $error"; + } + } + } + } + + if ( $seconds ) { + $dbh->rollback if $oldAutoCommit; + return "No svc_acct record to apply pre-paid time"; + } + + if ( @param ) { # INVOICING_LIST_ARYREF + my $invoicing_list = shift @param; + $error = $self->check_invoicing_list( $invoicing_list ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "checking invoicing_list (transaction rolled back): $error"; + } + $self->invoicing_list( $invoicing_list ); + } + + 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 "inserting credit (transaction rolled back): $error"; + } + } + + #false laziness with sub replace + my $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' }; + $error = $queue->insert($self->getfield('last'), $self->company); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + + if ( defined $self->dbdef_table->column('ship_last') && $self->ship_last ) { + $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' }; + $error = $queue->insert($self->getfield('last'), $self->company); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + } + #eslaf + + $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 uncancelled packages, you need to pass a new (valid) +customer number for those packages to be transferred to. Cancelled packages +will be deleted. Did I mention that this is NOT what you want when a customer +cancels service and that you really should be looking see L<FS::cust_pkg/cancel>? + +You can't delete a customer with invoices (see L<FS::cust_bill>), +or credits (see L<FS::cust_credit>), payments (see L<FS::cust_pay>) or +refunds (see L<FS::cust_refund>). + +=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"; + } + if ( qsearch( 'cust_pay', { 'custnum' => $self->custnum } ) ) { + $dbh->rollback if $oldAutoCommit; + return "Can't delete a customer with payments"; + } + if ( qsearch( 'cust_refund', { 'custnum' => $self->custnum } ) ) { + $dbh->rollback if $oldAutoCommit; + return "Can't delete a customer with refunds"; + } + + my @cust_pkg = $self->ncancelled_pkgs; + 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; + } + } + } + my @cancelled_cust_pkg = $self->all_pkgs; + foreach my $cust_pkg ( @cancelled_cust_pkg ) { + my $error = $cust_pkg->delete; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + foreach my $cust_main_invoice ( #(email invoice destinations, not invoices) + 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 [ INVOICING_LIST_ARYREF ] + +Replaces the OLD_RECORD with this one in the database. If there is an error, +returns the error, otherwise returns false. + +INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will +be set as the invoicing list (see L<"invoicing_list">). Errors return as +expected and rollback the entire transaction; it is not necessary to call +check_invoicing_list first. Here's an example: + + $new_cust_main->replace( $old_cust_main, [ $email, 'POST' ] ); + +=cut + +sub replace { + my $self = shift; + my $old = shift; + my @param = @_; + + 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 $error = $self->SUPER::replace($old); + + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + if ( @param ) { # INVOICING_LIST_ARYREF + my $invoicing_list = shift @param; + $error = $self->check_invoicing_list( $invoicing_list ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + $self->invoicing_list( $invoicing_list ); + } + + #false laziness with sub insert + my $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' }; + $error = $queue->insert($self->getfield('last'), $self->company); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + + if ( defined $self->dbdef_table->column('ship_last') && $self->ship_last ) { + $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' }; + $error = $queue->insert($self->getfield('last'), $self->company); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + } + #eslaf + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; + +} + +=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_name('last') + || $self->ut_name('first') + || $self->ut_textn('company') + || $self->ut_text('address1') + || $self->ut_textn('address2') + || $self->ut_text('city') + || $self->ut_textn('county') + || $self->ut_textn('state') + || $self->ut_country('country') + || $self->ut_anything('comments') + || $self->ut_numbern('referral_custnum') + ; + #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 } ); + + return "Unknown referring custnum ". $self->referral_custnum + unless ! $self->referral_custnum + || qsearchs( 'cust_main', { 'custnum' => $self->referral_custnum } ); + + 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"); + } + + unless ( $import ) { + 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) + || $self->ut_zip('zip', $self->country) + ; + return $error if $error; + + my @addfields = qw( + last first company address1 address2 city county state zip + country daytime night fax + ); + + if ( defined $self->dbdef_table->column('ship_last') ) { + if ( grep { $self->getfield($_) ne $self->getfield("ship_$_") } @addfields + && grep $self->getfield("ship_$_"), grep $_ ne 'state', @addfields + ) + { + my $error = + $self->ut_name('ship_last') + || $self->ut_name('ship_first') + || $self->ut_textn('ship_company') + || $self->ut_text('ship_address1') + || $self->ut_textn('ship_address2') + || $self->ut_text('ship_city') + || $self->ut_textn('ship_county') + || $self->ut_textn('ship_state') + || $self->ut_country('ship_country') + ; + return $error if $error; + + #false laziness with above + unless ( qsearchs('cust_main_county', { + 'country' => $self->ship_country, + 'state' => '', + } ) ) { + return "Unknown ship_state/ship_county/ship_country: ". + $self->ship_state. "/". $self->ship_county. "/". $self->ship_country + unless qsearchs('cust_main_county',{ + 'state' => $self->ship_state, + 'county' => $self->ship_county, + 'country' => $self->ship_country, + } ); + } + #eofalse + + $error = + $self->ut_phonen('ship_daytime', $self->ship_country) + || $self->ut_phonen('ship_night', $self->ship_country) + || $self->ut_phonen('ship_fax', $self->ship_country) + || $self->ut_zip('ship_zip', $self->ship_country) + ; + return $error if $error; + + } else { # ship_ info eq billing info, so don't store dup info in database + $self->setfield("ship_$_", '') + foreach qw( last first company address1 address2 city county state zip + country daytime night fax ); + } + } + + $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"); + } 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; + if ( $self->{'_pkgnum'} ) { + values %{ $self->{'_pkgnum'}->cache }; + } else { + 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; + if ( $self->{'_pkgnum'} ) { + grep { ! $_->getfield('cancel') } values %{ $self->{'_pkgnum'}->cache }; + } else { + @{ [ # force list context + qsearch( 'cust_pkg', { + 'custnum' => $self->custnum, + 'cancel' => '', + }), + qsearch( 'cust_pkg', { + 'custnum' => $self->custnum, + 'cancel' => 0, + }), + ] }; + } +} + +=item suspended_pkgs + +Returns all suspended packages (see L<FS::cust_pkg>) for this customer. + +=cut + +sub suspended_pkgs { + my $self = shift; + grep { $_->susp } $self->ncancelled_pkgs; +} + +=item unflagged_suspended_pkgs + +Returns all unflagged suspended packages (see L<FS::cust_pkg>) for this +customer (thouse packages without the `manual_flag' set). + +=cut + +sub unflagged_suspended_pkgs { + my $self = shift; + return $self->suspended_pkgs + unless dbdef->table('cust_pkg')->column('manual_flag'); + grep { ! $_->manual_flag } $self->suspended_pkgs; +} + +=item unsuspended_pkgs + +Returns all unsuspended (and uncancelled) packages (see L<FS::cust_pkg>) for +this customer. + +=cut + +sub unsuspended_pkgs { + my $self = shift; + grep { ! $_->susp } $self->ncancelled_pkgs; +} + +=item unsuspend + +Unsuspends all unflagged suspended packages (see L</unflagged_suspended_pkgs> +and L<FS::cust_pkg>) for this customer. Always returns a list: an empty list +on success or a list of errors. + +=cut + +sub unsuspend { + my $self = shift; + grep { $_->unsuspend } $self->suspended_pkgs; +} + +=item suspend + +Suspends all unsuspended packages (see L<FS::cust_pkg>) for this customer. +Always returns a list: an empty list on success or a list of errors. + +=cut + +sub suspend { + my $self = shift; + grep { $_->suspend } $self->unsuspended_pkgs; +} + +=item cancel + +Cancels all uncancelled packages (see L<FS::cust_pkg>) for this customer. +Always returns a list: an empty list on success or a list of errors. + +=cut + +sub cancel { + my $self = shift; + grep { $_->cancel } $self->ncancelled_pkgs; +} + +=item bill OPTIONS + +Generates invoices (see L<FS::cust_bill>) for this customer. Usually used in +conjunction with the collect method. + +Options are passed as name-value pairs. + +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. For example: + + use Date::Parse; + ... + $cust_main->bill( 'time' => str2time('April 20th, 2001') ); + +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( $taxable_setup, $taxable_recur ) = ( 0, 0 ); + my @cust_bill_pkg = (); + + foreach my $cust_pkg ( + qsearch('cust_pkg', { 'custnum' => $self->custnum } ) + ) { + + #NO!! next if $cust_pkg->cancel; + next if $cust_pkg->getfield('cancel'); + + #? to avoid use of uninitialized value errors... ? + $cust_pkg->setfield('bill', '') + unless defined($cust_pkg->bill); + + my $part_pkg = qsearchs( 'part_pkg', { 'pkgpart' => $cust_pkg->pkgpart } ); + + #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'); + $setup_prog =~ /^(.*)$/ or do { + $dbh->rollback if $oldAutoCommit; + return "Illegal setup for pkgpart ". $part_pkg->pkgpart. + ": $setup_prog"; + }; + $setup_prog = $1; + + #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); + $setup = eval $setup_prog; + unless ( defined($setup) ) { + $dbh->rollback if $oldAutoCommit; + return "Error eval-ing part_pkg->setup pkgpart ". $part_pkg->pkgpart. + "(expression $setup_prog): $@"; + } + $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'); + $recur_prog =~ /^(.*)$/ or do { + $dbh->rollback if $oldAutoCommit; + return "Illegal recur for pkgpart ". $part_pkg->pkgpart. + ": $recur_prog"; + }; + $recur_prog = $1; + + # shared with $recur_prog + $sdate = $cust_pkg->bill || $cust_pkg->setup || $time; + + #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); + $recur = eval $recur_prog; + unless ( defined($recur) ) { + $dbh->rollback if $oldAutoCommit; + return "Error eval-ing part_pkg->recur pkgpart ". $part_pkg->pkgpart. + "(expression $recur_prog): $@"; + } + #change this bit to use Date::Manip? CAREFUL with timezones (see + # mailing list archive) + my ($sec,$min,$hour,$mday,$mon,$year) = + (localtime($sdate) )[0,1,2,3,4,5]; + + #pro-rating magic - if $recur_prog fiddles $sdate, want to use that + # only for figuring next bill date, nothing else, so, reset $sdate again + # here + $sdate = $cust_pkg->bill || $cust_pkg->setup || $time; + + $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 + $dbh->rollback if $oldAutoCommit; + return "Error modifying pkgnum ". $cust_pkg->pkgnum. ": $error"; + } + $setup = sprintf( "%.2f", $setup ); + $recur = sprintf( "%.2f", $recur ); + if ( $setup < 0 ) { + $dbh->rollback if $oldAutoCommit; + return "negative setup $setup for pkgnum ". $cust_pkg->pkgnum; + } + if ( $recur < 0 ) { + $dbh->rollback if $oldAutoCommit; + return "negative recur $recur for pkgnum ". $cust_pkg->pkgnum; + } + if ( $setup > 0 || $recur > 0 ) { + 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; + $taxable_setup += $setup + unless $part_pkg->dbdef_table->column('setuptax') + && $part_pkg->setuptax =~ /^Y$/i; + $taxable_recur += $recur + unless $part_pkg->dbdef_table->column('recurtax') + && $part_pkg->recurtax =~ /^Y$/i; + } + } + + } + + my $charged = sprintf( "%.2f", $total_setup + $total_recur ); + my $taxable_charged = sprintf( "%.2f", $taxable_setup + $taxable_recur ); + + unless ( @cust_bill_pkg ) { + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + return ''; + } + + unless ( $self->tax =~ /Y/i + || $self->payby eq 'COMP' + || $taxable_charged == 0 ) { + my $cust_main_county = qsearchs('cust_main_county',{ + 'state' => $self->state, + 'county' => $self->county, + 'country' => $self->country, + } ); + my $tax = sprintf( "%.2f", + $taxable_charged * ( $cust_main_county->getfield('tax') / 100 ) + ); + + if ( $tax > 0 ) { + $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->custnum, + '_date' => $time, + 'charged' => $charged, + } ); + $error = $cust_bill->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "can't create invoice for customer #". $self->custnum. ": $error"; + } + + my $invnum = $cust_bill->invnum; + my $cust_bill_pkg; + foreach $cust_bill_pkg ( @cust_bill_pkg ) { + #warn $invnum; + $cust_bill_pkg->invnum($invnum); + $error = $cust_bill_pkg->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "can't create invoice line item for customer #". $self->custnum. + ": $error"; + } + } + + $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'). + +Most actions are now triggered by invoice events; see L<FS::part_bill_event> +and the invoice events web interface. + +If there is an error, returns the error, otherwise returns false. + +Options are passed as name-value pairs. + +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 - This option is deprecated. See the invoice events web interface +to control whether cards are batched or run against a realtime gateway. + +report_badcard - This option is deprecated. + +force_print - This option is deprecated; see the invoice events web interface. + +=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 $balance = $self->balance; + warn "collect: balance $balance" if $Debug; + unless ( $balance > 0 ) { #redundant????? + $dbh->rollback if $oldAutoCommit; #hmm + return ''; + } + + foreach my $cust_bill ( + qsearch('cust_bill', { 'custnum' => $self->custnum, } ) + ) { + + #this has to be before next's + my $amount = sprintf( "%.2f", $balance < $cust_bill->owed + ? $balance + : $cust_bill->owed + ); + $balance = sprintf( "%.2f", $balance - $amount ); + + next unless $cust_bill->owed > 0; + + # don't try to charge for the same invoice if it's already in a batch + #next if qsearchs( 'cust_pay_batch', { 'invnum' => $cust_bill->invnum } ); + + warn "invnum ". $cust_bill->invnum. " (owed ". $cust_bill->owed. ", amount $amount, balance $balance)" if $Debug; + + next unless $amount > 0; + + foreach my $part_bill_event ( + sort { $a->seconds <=> $b->seconds + || $a->weight <=> $b->weight + || $a->eventpart <=> $b->eventpart } + grep { $_->seconds <= ( $invoice_time - $cust_bill->_date ) + && ! qsearchs( 'cust_bill_event', { + 'invnum' => $cust_bill->invnum, + 'eventpart' => $_->eventpart } ) + } + qsearch('part_bill_event', { 'payby' => $self->payby, + 'disabled' => '', } ) + ) { + #run callback + my $cust_main = $self; #for callback + my $error = eval $part_bill_event->eventcode; + + if ( $error ) { + + warn "Error running invoice event (". $part_bill_event->eventcode. + "): $error"; + + } else { + + #add cust_bill_event + my $cust_bill_event = new FS::cust_bill_event { + 'invnum' => $cust_bill->invnum, + 'eventpart' => $part_bill_event->eventpart, + '_date' => $invoice_time, + }; + $cust_bill_event->insert; + if ( $error ) { + #$dbh->rollback if $oldAutoCommit; + #return "error: $error"; + + # gah, even with transactions. + $dbh->commit if $oldAutoCommit; #well. + my $e = 'WARNING: Event run but database not updated - '. + 'error inserting cust_bill_event, invnum #'. $cust_bill->invnum. + ', eventpart '. $part_bill_event->eventpart. + ": $error"; + warn $e; + return $e; + } + + } + + } + + } + + $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/owed>). + +=cut + +sub total_owed { + my $self = shift; + $self->total_owed_date(2145859200); #12/31/2037 +} + +=item total_owed_date TIME + +Returns the total owed for this customer on all invoices with date earlier than +TIME. TIME is specified as a UNIX timestamp; see L<perlfunc/"time">). Also +see L<Time::Local> and L<Date::Parse> for conversion functions. + +=cut + +sub total_owed_date { + my $self = shift; + my $time = shift; + my $total_bill = 0; + foreach my $cust_bill ( + grep { $_->_date <= $time } + qsearch('cust_bill', { 'custnum' => $self->custnum, } ) + ) { + $total_bill += $cust_bill->owed; + } + sprintf( "%.2f", $total_bill ); +} + +=item apply_credits + +Applies (see L<FS::cust_credit_bill>) unapplied credits (see L<FS::cust_credit>) +to outstanding invoice balances in chronological order and returns the value +of any remaining unapplied credits available for refund +(see L<FS::cust_refund>). + +=cut + +sub apply_credits { + my $self = shift; + + return 0 unless $self->total_credited; + + my @credits = sort { $b->_date <=> $a->_date} (grep { $_->credited > 0 } + qsearch('cust_credit', { 'custnum' => $self->custnum } ) ); + + my @invoices = sort { $a->_date <=> $b->_date} (grep { $_->owed > 0 } + qsearch('cust_bill', { 'custnum' => $self->custnum } ) ); + + my $credit; + + foreach my $cust_bill ( @invoices ) { + my $amount; + + if ( !defined($credit) || $credit->credited == 0) { + $credit = pop @credits or last; + } + + if ($cust_bill->owed >= $credit->credited) { + $amount=$credit->credited; + }else{ + $amount=$cust_bill->owed; + } + + my $cust_credit_bill = new FS::cust_credit_bill ( { + 'crednum' => $credit->crednum, + 'invnum' => $cust_bill->invnum, + 'amount' => $amount, + } ); + my $error = $cust_credit_bill->insert; + die $error if $error; + + redo if ($cust_bill->owed > 0); + + } + + return $self->total_credited; +} + +=item apply_payments + +Applies (see L<FS::cust_bill_pay>) unapplied payments (see L<FS::cust_pay>) +to outstanding invoice balances in chronological order. + + #and returns the value of any remaining unapplied payments. + +=cut + +sub apply_payments { + my $self = shift; + + #return 0 unless + + my @payments = sort { $b->_date <=> $a->_date } ( grep { $_->unapplied > 0 } + qsearch('cust_pay', { 'custnum' => $self->custnum } ) ); + + my @invoices = sort { $a->_date <=> $b->_date} (grep { $_->owed > 0 } + qsearch('cust_bill', { 'custnum' => $self->custnum } ) ); + + my $payment; + + foreach my $cust_bill ( @invoices ) { + my $amount; + + if ( !defined($payment) || $payment->unapplied == 0 ) { + $payment = pop @payments or last; + } + + if ( $cust_bill->owed >= $payment->unapplied ) { + $amount = $payment->unapplied; + } else { + $amount = $cust_bill->owed; + } + + my $cust_bill_pay = new FS::cust_bill_pay ( { + 'paynum' => $payment->paynum, + 'invnum' => $cust_bill->invnum, + 'amount' => $amount, + } ); + my $error = $cust_bill_pay->insert; + die $error if $error; + + redo if ( $cust_bill->owed > 0); + + } + + return $self->total_unapplied_payments; +} + +=item total_credited + +Returns the total outstanding credit (see L<FS::cust_credit>) for this +customer. See L<FS::cust_credit/credited>. + +=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 total_unapplied_payments + +Returns the total unapplied payments (see L<FS::cust_pay>) for this customer. +See L<FS::cust_pay/unapplied>. + +=cut + +sub total_unapplied_payments { + my $self = shift; + my $total_unapplied = 0; + foreach my $cust_pay ( qsearch('cust_pay', { + 'custnum' => $self->custnum, + } ) ) { + $total_unapplied += $cust_pay->unapplied; + } + sprintf( "%.2f", $total_unapplied ); +} + +=item balance + +Returns the balance for this customer (total_owed minus total_credited +minus total_unapplied_payments). + +=cut + +sub balance { + my $self = shift; + sprintf( "%.2f", + $self->total_owed - $self->total_credited - $self->total_unapplied_payments + ); +} + +=item balance_date TIME + +Returns the balance for this customer, only considering invoices with date +earlier than TIME (total_owed_date minus total_credited minus +total_unapplied_payments). TIME is specified as a UNIX timestamp; see +L<perlfunc/"time">). Also see L<Time::Local> and L<Date::Parse> for conversion +functions. + +=cut + +sub balance_date { + my $self = shift; + my $time = shift; + sprintf( "%.2f", + $self->total_owed_date($time) + - $self->total_credited + - $self->total_unapplied_payments + ); +} + +=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 = (); + } + my %seen = map { $_->address => 1 } @cust_main_invoice; + foreach my $address ( @{$arrayref} ) { + #unless ( grep { $address eq $_->address } @cust_main_invoice ) { + next if exists $seen{$address} && $seen{$address}; + $seen{$address} = 1; + 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; + } + ''; +} + +=item default_invoicing_list + +Sets the invoicing list to all accounts associated with this customer. + +=cut + +sub default_invoicing_list { + my $self = shift; + my @list = (); + foreach my $cust_pkg ( $self->all_pkgs ) { + my @cust_svc = qsearch('cust_svc', { 'pkgnum' => $cust_pkg->pkgnum } ); + my @svc_acct = + map { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) } + grep { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) } + @cust_svc; + push @list, map { $_->email } @svc_acct; + } + $self->invoicing_list(\@list); +} + +=item invoicing_list_addpost + +Adds postal invoicing to this customer. If this customer is already configured +to receive postal invoices, does nothing. + +=cut + +sub invoicing_list_addpost { + my $self = shift; + return if grep { $_ eq 'POST' } $self->invoicing_list; + my @invoicing_list = $self->invoicing_list; + push @invoicing_list, 'POST'; + $self->invoicing_list(\@invoicing_list); +} + +=item referral_cust_main [ DEPTH [ EXCLUDE_HASHREF ] ] + +Returns an array of customers referred by this customer (referral_custnum set +to this custnum). If DEPTH is given, recurses up to the given depth, returning +customers referred by customers referred by this customer and so on, inclusive. +The default behavior is DEPTH 1 (no recursion). + +=cut + +sub referral_cust_main { + my $self = shift; + my $depth = @_ ? shift : 1; + my $exclude = @_ ? shift : {}; + + my @cust_main = + map { $exclude->{$_->custnum}++; $_; } + grep { ! $exclude->{ $_->custnum } } + qsearch( 'cust_main', { 'referral_custnum' => $self->custnum } ); + + if ( $depth > 1 ) { + push @cust_main, + map { $_->referral_cust_main($depth-1, $exclude) } + @cust_main; + } + + @cust_main; +} + +=item referral_cust_main_ncancelled + +Same as referral_cust_main, except only returns customers with uncancelled +packages. + +=cut + +sub referral_cust_main_ncancelled { + my $self = shift; + grep { scalar($_->ncancelled_pkgs) } $self->referral_cust_main; +} + +=item referral_cust_pkg [ DEPTH ] + +Like referral_cust_main, except returns a flat list of all unsuspended (and +uncancelled) packages for each customer. The number of items in this list may +be useful for comission calculations (perhaps after a C<grep { my $pkgpart = $_->pkgpart; grep { $_ == $pkgpart } @commission_worthy_pkgparts> } $cust_main-> ). + +=cut + +sub referral_cust_pkg { + my $self = shift; + my $depth = @_ ? shift : 1; + + map { $_->unsuspended_pkgs } + grep { $_->unsuspended_pkgs } + $self->referral_cust_main($depth); +} + +=item credit AMOUNT, REASON + +Applies a credit to this customer. If there is an error, returns the error, +otherwise returns false. + +=cut + +sub credit { + my( $self, $amount, $reason ) = @_; + my $cust_credit = new FS::cust_credit { + 'custnum' => $self->custnum, + 'amount' => $amount, + 'reason' => $reason, + }; + $cust_credit->insert; +} + +=item charge AMOUNT PKG COMMENT + +Creates a one-time charge for this customer. If there is an error, returns +the error, otherwise returns false. + +=cut + +sub charge { + my ( $self, $amount, $pkg, $comment ) = @_; + + my $part_pkg = new FS::part_pkg ( { + 'pkg' => $pkg || 'One-time charge', + 'comment' => $comment || '$'. sprintf("%.2f".$amount), + 'setup' => $amount, + 'freq' => 0, + 'recur' => '0', + 'disabled' => 'Y', + } ); + + $part_pkg->insert; + +} + +=back + +=head1 SUBROUTINES + +=over 4 + +=item check_and_rebuild_fuzzyfiles + +=cut + +sub check_and_rebuild_fuzzyfiles { + my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc; + -e "$dir/cust_main.last" && -e "$dir/cust_main.company" + or &rebuild_fuzzyfiles; +} + +=item rebuild_fuzzyfiles + +=cut + +sub rebuild_fuzzyfiles { + + use Fcntl qw(:flock); + + my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc; + + #last + + open(LASTLOCK,">>$dir/cust_main.last") + or die "can't open $dir/cust_main.last: $!"; + flock(LASTLOCK,LOCK_EX) + or die "can't lock $dir/cust_main.last: $!"; + + my @all_last = map $_->getfield('last'), qsearch('cust_main', {}); + push @all_last, + grep $_, map $_->getfield('ship_last'), qsearch('cust_main',{}) + if defined dbdef->table('cust_main')->column('ship_last'); + + open (LASTCACHE,">$dir/cust_main.last.tmp") + or die "can't open $dir/cust_main.last.tmp: $!"; + print LASTCACHE join("\n", @all_last), "\n"; + close LASTCACHE or die "can't close $dir/cust_main.last.tmp: $!"; + + rename "$dir/cust_main.last.tmp", "$dir/cust_main.last"; + close LASTLOCK; + + #company + + open(COMPANYLOCK,">>$dir/cust_main.company") + or die "can't open $dir/cust_main.company: $!"; + flock(COMPANYLOCK,LOCK_EX) + or die "can't lock $dir/cust_main.company: $!"; + + my @all_company = grep $_ ne '', map $_->company, qsearch('cust_main',{}); + push @all_company, + grep $_ ne '', map $_->ship_company, qsearch('cust_main', {}) + if defined dbdef->table('cust_main')->column('ship_last'); + + open (COMPANYCACHE,">$dir/cust_main.company.tmp") + or die "can't open $dir/cust_main.company.tmp: $!"; + print COMPANYCACHE join("\n", @all_company), "\n"; + close COMPANYCACHE or die "can't close $dir/cust_main.company.tmp: $!"; + + rename "$dir/cust_main.company.tmp", "$dir/cust_main.company"; + close COMPANYLOCK; + +} + +=item all_last + +=cut + +sub all_last { + my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc; + open(LASTCACHE,"<$dir/cust_main.last") + or die "can't open $dir/cust_main.last: $!"; + my @array = map { chomp; $_; } <LASTCACHE>; + close LASTCACHE; + \@array; +} + +=item all_company + +=cut + +sub all_company { + my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc; + open(COMPANYCACHE,"<$dir/cust_main.company") + or die "can't open $dir/cust_main.last: $!"; + my @array = map { chomp; $_; } <COMPANYCACHE>; + close COMPANYCACHE; + \@array; +} + +=item append_fuzzyfiles LASTNAME COMPANY + +=cut + +sub append_fuzzyfiles { + my( $last, $company ) = @_; + + &check_and_rebuild_fuzzyfiles; + + use Fcntl qw(:flock); + + my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc; + + if ( $last ) { + + open(LAST,">>$dir/cust_main.last") + or die "can't open $dir/cust_main.last: $!"; + flock(LAST,LOCK_EX) + or die "can't lock $dir/cust_main.last: $!"; + + print LAST "$last\n"; + + flock(LAST,LOCK_UN) + or die "can't unlock $dir/cust_main.last: $!"; + close LAST; + } + + if ( $company ) { + + open(COMPANY,">>$dir/cust_main.company") + or die "can't open $dir/cust_main.company: $!"; + flock(COMPANY,LOCK_EX) + or die "can't lock $dir/cust_main.company: $!"; + + print COMPANY "$company\n"; + + flock(COMPANY,LOCK_UN) + or die "can't unlock $dir/cust_main.company: $!"; + + close COMPANY; + } + + 1; +} + +=back + +=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. + +There should probably be a configuration file with a list of allowed credit +card types. + +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::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..ebbadc6d9 --- /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); +use Exporter; +use FS::Record qw( qsearchs ); +use FS::Conf; +use FS::cust_main; +use FS::svc_acct; + +@ISA = qw( FS::Record ); + +=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($old); +} + + +=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. If it finds that the account ends in the +same domain configured as the B<domain> configuration file, it will change the +invoice destination from an email address to a service number (see +L<FS::svc_acct>). + +=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: ". $self->dest. ")" + 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: $user\@$domain (specified literally)" +# unless $svc_acct; +# $svc_acct->svcnum =~ /^(\d+)$/ or die "Non-numeric svcnum?!"; +# $self->dest($1); +# } + $self->dest("$1\@$2"); + } 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 } ) + or return undef; + $svc_acct->email; + } else { + $self->dest; + } +} + +=back + +=head1 VERSION + +$Id: cust_main_invoice.pm,v 1.10 2002-02-10 17:02:37 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..6156eadeb --- /dev/null +++ b/FS/FS/cust_pay.pm @@ -0,0 +1,376 @@ +package FS::cust_pay; + +use strict; +use vars qw( @ISA $conf $unsuspendauto ); +use Business::CreditCard; +use FS::UID qw( dbh ); +use FS::Record qw( dbh qsearch qsearchs dbh ); +use FS::cust_bill; +use FS::cust_bill_pay; +use FS::cust_main; + +@ISA = qw( FS::Record ); + +#ask FS::UID to run this stuff for us later +$FS::UID::callback{'FS::cust_pay'} = sub { + + $conf = new FS::Conf; + $unsuspendauto = $conf->exists('unsuspendauto'); + +}; + +=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 custnum - customer (see L<FS::cust_main>) + +=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, check #, or comp issuer (4-8 lowercase alphanumerics; think username), respectively + +=item paybatch - text field for tracking card processing + +=item closed - books closed flag, empty or `Y' + +=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 database. + +For backwards-compatibility and convenience, if the additional field invnum +is defined, an FS::cust_bill_pay record for the full amount of the payment +will be created. In this case, custnum is optional. + +=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; + + if ( $self->invnum ) { + my $cust_bill = qsearchs('cust_bill', { 'invnum' => $self->invnum } ) + or do { + $dbh->rollback if $oldAutoCommit; + return "Unknown cust_bill.invnum: ". $self->invnum; + }; + $self->custnum($cust_bill->custnum ); + } + + my $cust_main = qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); + my $old_balance = $cust_main->balance; + + my $error = $self->check; + return $error if $error; + + $error = $self->SUPER::insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "error inserting $self: $error"; + } + + if ( $self->invnum ) { + my $cust_bill_pay = new FS::cust_bill_pay { + 'invnum' => $self->invnum, + 'paynum' => $self->paynum, + 'amount' => $self->paid, + '_date' => $self->_date, + }; + $error = $cust_bill_pay->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "error inserting $cust_bill_pay: $error"; + } + } + + if ( $self->paybatch =~ /^webui-/ ) { + my @cust_pay = qsearch('cust_pay', { + 'custnum' => $self->custnum, + 'paybatch' => $self->paybatch, + } ); + if ( scalar(@cust_pay) > 1 ) { + $dbh->rollback if $oldAutoCommit; + return "a payment with webui token ". $self->paybatch. " already exists"; + } + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + #false laziness w/ cust_credit::insert + if ( $unsuspendauto && $old_balance && $cust_main->balance <= 0 ) { + my @errors = $cust_main->unsuspend; + #return + # side-fx with nested transactions? upstack rolls back? + warn "WARNING:Errors unsuspending customer ". $cust_main->custnum. ": ". + join(' / ', @errors) + if @errors; + } + #eslaf + + ''; + +} + +sub upgrade_replace { #1.3.x->1.4.x + 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 $error = $self->check; + return $error if $error; + + my %new = $self->hash; + my $new = FS::cust_pay->new(\%new); + + if ( $self->invnum ) { + my $cust_bill_pay = new FS::cust_bill_pay { + 'invnum' => $self->invnum, + 'paynum' => $self->paynum, + 'amount' => $self->paid, + '_date' => $self->_date, + }; + $error = $cust_bill_pay->insert; + if ( $error =~ + /total cust_bill_pay.amount and cust_credit_bill.amount .* for invnum .* greater than cust_bill.charged/ ) { + #warn $error; + my $cust_bill = qsearchs( 'cust_bill', { 'invnum' => $self->invnum } ); + $new->custnum($cust_bill->custnum); + } elsif ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } else { + $new->custnum($cust_bill_pay->cust_bill->custnum); + } + } else { + die; + } + + $error = $new->SUPER::replace($self); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; + + +} + +=item delete + +Deletes this payment and all associated applications (see L<FS::cust_bill_pay>), +unless the closed flag is set. + +=cut + +sub delete { + my $self = shift; + return "Can't delete closed payment" if $self->closed =~ /^Y/i; + + 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_bill_pay ( $self->cust_bill_pay ) { + my $error = $cust_bill_pay->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 + +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 = + $self->ut_numbern('paynum') + || $self->ut_numbern('custnum') + || $self->ut_money('paid') + || $self->ut_numbern('_date') + || $self->ut_textn('paybatch') + || $self->ut_enum('closed', [ '', 'Y' ]) + ; + return $error if $error; + + return "paid must be > 0 " if $self->paid <= 0; + + return "unknown cust_main.custnum: ". $self->custnum + unless $self->invnum + || qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); + + $self->_date(time) unless $self->_date; + + $self->payby =~ /^(CARD|BILL|COMP)$/ or return "Illegal payby"; + $self->payby($1); + + #false laziness with cust_refund::check + 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; + } + + ''; #no error + +} + +=item cust_bill_pay + +Returns all applications to invoices (see L<FS::cust_bill_pay>) for this +payment. + +=cut + +sub cust_bill_pay { + my $self = shift; + sort { $a->_date <=> $b->_date } + qsearch( 'cust_bill_pay', { 'paynum' => $self->paynum } ) + ; +} + +=item unapplied + +Returns the amount of this payment that is still unapplied; which is +paid minus all payment applications (see L<FS::cust_bill_pay>). + +=cut + +sub unapplied { + my $self = shift; + my $amount = $self->paid; + $amount -= $_->amount foreach ( $self->cust_bill_pay ); + sprintf("%.2f", $amount ); +} + +=back + +=head1 VERSION + +$Id: cust_pay.pm,v 1.17 2002-02-10 18:56:49 ivan Exp $ + +=head1 BUGS + +Delete and replace methods. + +=head1 SEE ALSO + +L<FS::cust_bill_pay>, L<FS::cust_bill>, L<FS::Record>, 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..c4427c387 --- /dev/null +++ b/FS/FS/cust_pay_batch.pm @@ -0,0 +1,209 @@ +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 paybatchnum - primary key (automatically assigned) + +=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('paybatchnum') + || $self->ut_numbern('trancode') #depriciated + || $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_textn('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); + + $error = $self->ut_zip('zip', $self->country); + return $error if $error; + + #check invnum, custnum, ? + + ''; #no error +} + +=back + +=head1 VERSION + +$Id: cust_pay_batch.pm,v 1.6 2002-02-22 23:08:11 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..b241ecac2 --- /dev/null +++ b/FS/FS/cust_pkg.pm @@ -0,0 +1,687 @@ +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; +use FS::svc_forward; + +@ISA = qw( FS::Record ); + +sub _cache { + my $self = shift; + my ( $hashref, $cache ) = @_; + #if ( $hashref->{'pkgpart'} ) { + if ( $hashref->{'pkg'} ) { + # #@{ $self->{'_pkgnum'} } = (); + # my $subcache = $cache->subcache('pkgpart', 'part_pkg'); + # $self->{'_pkgpart'} = $subcache; + # #push @{ $self->{'_pkgnum'} }, + # FS::part_pkg->new_or_cached($hashref, $subcache); + $self->{'_pkgpart'} = FS::part_pkg->new($hashref); + } + if ( exists $hashref->{'svcnum'} ) { + #@{ $self->{'_pkgnum'} } = (); + my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum}); + $self->{'_svcnum'} = $subcache; + #push @{ $self->{'_pkgnum'} }, + FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum}; + } +} + +=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; + + $seconds = $record->seconds_since($timestamp); + + $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>) + +=item manual_flag - If this field is set to 1, disables the automatic +unsuspension of this package when using the B<unsuspendauto> config file. + +=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. + +=cut + +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 + # (is this still necessary with transactions?) + + my $error = $self->ut_number('custnum'); + return $error if $error; + + return "Unknown customer ". $self->custnum unless $self->cust_main; + + $self->SUPER::insert; + +} + +=item delete + +This method now works but you probably shouldn't use it. + +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; + + #allow this *sigh* + #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 ". $self->custnum unless $self->cust_main; + } + + 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); + + if ( $self->dbdef_table->column('manual_flag') ) { + $self->manual_flag =~ /^([01]?)$/ or return "Illegal manual_flag"; + $self->manual_flag($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; + #exists( $self->{'_pkgpart'} ) + $self->{'_pkgpart'} + ? $self->{'_pkgpart'} + : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } ); +} + +=item cust_svc + +Returns the services for this package, as FS::cust_svc objects (see +L<FS::cust_svc>) + +=cut + +sub cust_svc { + my $self = shift; + if ( $self->{'_svcnum'} ) { + values %{ $self->{'_svcnum'}->cache }; + } else { + qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } ); + } +} + +=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 ] } $self->cust_svc; +} + +=item cust_main + +Returns the parent customer object (see L<FS::cust_main>). + +=cut + +sub cust_main { + my $self = shift; + qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); +} + +=item seconds_since TIMESTAMP + +Returns the number of seconds all accounts (see L<FS::svc_acct>) in this +package have been online since TIMESTAMP. + +TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see +L<Time::Local> and L<Date::Parse> for conversion functions. + +=cut + +sub seconds_since { + my($self, $since) = @_; + my $seconds = 0; + + foreach my $cust_svc ( + grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc + ) { + $seconds += $cust_svc->seconds_since($since); + } + + $seconds; + +} + +=back + +=head1 SUBROUTINES + +=over 4 + +=item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ] + +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>). An empty arrayref is equivalent to not specifying this +parameter. + +RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the +newly-created cust_pkg objects. + +=cut + +sub order { + my($custnum, $pkgparts, $remove_pkgnums, $return_cust_pkg) = @_; + $remove_pkgnums = [] unless defined($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; + return "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; + return "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; + return "Couldn't insert new cust_pkg record: $error"; + } + push @{$return_cust_pkg}, $new if $return_cust_pkg; + my $pkgnum = $new->pkgnum; + + foreach my $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; + return "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.16 2002-01-29 16:33: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. + +Now that things are transactional should the check in the insert method be +moved to check ? + +=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..8fe6876d3 --- /dev/null +++ b/FS/FS/cust_refund.pm @@ -0,0 +1,282 @@ +package FS::cust_refund; + +use strict; +use vars qw( @ISA ); +use Business::CreditCard; +use FS::Record qw( qsearchs dbh ); +use FS::UID qw(getotaker); +use FS::cust_credit; +use FS::cust_credit_refund; +use FS::cust_main; + +@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 custnum - customer (see L<FS::cust_main>) + +=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 paybatch - text field for tracking card processing + +=item otaker - order taker (assigned automatically, see L<FS::UID>) + +=item closed - books closed flag, empty or `Y' + +=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. + +For backwards-compatibility and convenience, if the additional field crednum is +defined, an FS::cust_credit_refund record for the full amount of the refund +will be created. In this case, custnum is optional. + +=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; + + if ( $self->crednum ) { + my $cust_credit = qsearchs('cust_credit', { 'crednum' => $self->crednum } ) + or do { + $dbh->rollback if $oldAutoCommit; + return "Unknown cust_credit.crednum: ". $self->crednum; + }; + $self->custnum($cust_credit->custnum); + } + + my $error = $self->check; + return $error if $error; + + $error = $self->SUPER::insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + if ( $self->crednum ) { + my $cust_credit_refund = new FS::cust_credit_refund { + 'crednum' => $self->crednum, + 'refundnum' => $self->refundnum, + 'amount' => $self->refund, + '_date' => $self->_date, + }; + $error = $cust_credit_refund->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + #$self->custnum($cust_credit_refund->cust_credit->custnum); + } + + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; + +} + +sub upgrade_replace { #1.3.x->1.4.x + 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 $error = $self->check; + return $error if $error; + + my %new = $self->hash; + my $new = FS::cust_refund->new(\%new); + + if ( $self->crednum ) { + my $cust_credit_refund = new FS::cust_credit_refund { + 'crednum' => $self->crednum, + 'refundnum' => $self->refundnum, + 'amount' => $self->refund, + '_date' => $self->_date, + }; + $error = $cust_credit_refund->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + $new->custnum($cust_credit_refund->cust_credit->custnum); + } else { + die; + } + + $error = $new->SUPER::replace($self); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; + +} + +=item delete + +Currently unimplemented (accounting reasons). + +=cut + +sub delete { + my $self = shift; + return "Can't delete closed refund" if $self->closed =~ /^Y/i; + $self->SUPER::delete(@_); +} + +=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 = + $self->ut_numbern('refundnum') + || $self->ut_numbern('custnum') + || $self->ut_money('refund') + || $self->ut_numbern('_date') + || $self->ut_textn('paybatch') + || $self->ut_enum('closed', [ '', 'Y' ]) + ; + return $error if $error; + + return "refund must be > 0 " if $self->refund <= 0; + + $self->_date(time) unless $self->_date; + + return "unknown cust_main.custnum: ". $self->custnum + unless $self->crednum + || qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); + + $self->payby =~ /^(CARD|BILL|COMP)$/ or return "Illegal payby"; + $self->payby($1); + + #false laziness with cust_pay::check + 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; + } + + $self->otaker(getotaker); + + ''; #no error +} + +=back + +=head1 VERSION + +$Id: cust_refund.pm,v 1.18 2002-02-19 03:22:39 jeff 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..3e38be39e --- /dev/null +++ b/FS/FS/cust_svc.pm @@ -0,0 +1,268 @@ +package FS::cust_svc; + +use strict; +use vars qw( @ISA ); +use Carp qw( cluck ); +use FS::Record qw( qsearch qsearchs dbh ); +use FS::cust_pkg; +use FS::part_pkg; +use FS::part_svc; +use FS::pkg_svc; +use FS::svc_acct; +use FS::svc_acct_sm; +use FS::svc_domain; +use FS::svc_forward; +use FS::domain_record; + +@ISA = qw( FS::Record ); + +sub _cache { + my $self = shift; + my ( $hashref, $cache ) = @_; + if ( $hashref->{'username'} ) { + $self->{'_svc_acct'} = FS::svc_acct->new($hashref, ''); + } + if ( $hashref->{'svc'} ) { + $self->{'_svcpart'} = FS::part_svc->new($hashref); + } +} + +=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_forward>, 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; + + my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } ); + return "Unknown svcpart" unless $part_svc; + + if ( $self->pkgnum ) { + my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } ); + return "Unknown pkgnum" unless $cust_pkg; + my $pkg_svc = qsearchs( 'pkg_svc', { + 'pkgpart' => $cust_pkg->pkgpart, + 'svcpart' => $self->svcpart, + }); + my @cust_svc = qsearch('cust_svc', { + 'pkgnum' => $self->pkgnum, + 'svcpart' => $self->svcpart, + }); + return "Already ". scalar(@cust_svc). " ". $part_svc->svc. + " services for pkgnum ". $self->pkgnum + if scalar(@cust_svc) >= $pkg_svc->quantity; + } + + ''; #no error +} + +=item part_svc + +Returns the definition for this service, as a FS::part_svc object (see +L<FS::part_svc>). + +=cut + +sub part_svc { + my $self = shift; + $self->{'_svcpart'} + ? $self->{'_svcpart'} + : qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } ); +} + +=item cust_pkg + +Returns the definition for this service, as a FS::part_svc object (see +L<FS::part_svc>). + +=cut + +sub cust_pkg { + my $self = shift; + qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } ); +} + +=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 $svcdb = $self->part_svc->svcdb; + my $svc_x = $self->svc_x + or die "can't find $svcdb.svcnum ". $self->svcnum; + my $tag; + if ( $svcdb eq 'svc_acct' ) { + $tag = $svc_x->email; + } 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_forward' ) { + my $svc_acct = qsearchs( 'svc_acct', { 'svcnum' => $svc_x->srcsvc } ); + $tag = $svc_acct->email. '->'; + if ( $svc_x->dstsvc ) { + $svc_acct = qsearchs( 'svc_acct', { 'svcnum' => $svc_x->dstsvc } ); + $tag .= $svc_acct->email; + } else { + $tag .= $svc_x->dst; + } + } elsif ( $svcdb eq 'svc_domain' ) { + $tag = $svc_x->getfield('domain'); + } elsif ( $svcdb eq 'svc_www' ) { + my $domain = qsearchs( 'domain_record', { 'recnum' => $svc_x->recnum } ); + $tag = $domain->reczone; + } else { + cluck "warning: asked for label of unsupported svcdb; using svcnum"; + $tag = $svc_x->getfield('svcnum'); + } + $self->part_svc->svc, $tag, $svcdb; +} + +=item svc_x + +Returns the FS::svc_XXX object for this service (i.e. an FS::svc_acct object or +FS::svc_domain object, etc.) + +=cut + +sub svc_x { + my $self = shift; + my $svcdb = $self->part_svc->svcdb; + if ( $svcdb eq 'svc_acct' && $self->{'_svc_acct'} ) { + $self->{'_svc_acct'}; + } else { + qsearchs( $svcdb, { 'svcnum' => $self->svcnum } ); + } +} + +=item seconds_since TIMESTAMP + +See L<FS::svc_acct/seconds_since>. Equivalent to +$cust_svc->svc_x->seconds_since, but more efficient. Meaningless for records +where B<svcdb> is not "svc_acct". + +=cut + +#note: implementation here, POD in FS::svc_acct +sub seconds_since { + my($self, $since) = @_; + my $dbh = dbh; + my $sth = $dbh->prepare(' SELECT SUM(logout-login) FROM session + WHERE svcnum = ? + AND login >= ? + AND logout IS NOT NULL' + ) or die $dbh->errstr; + $sth->execute($self->svcnum, $since) or die $sth->errstr; + $sth->fetchrow_arrayref->[0]; +} + +=back + +=head1 VERSION + +$Id: cust_svc.pm,v 1.12 2002-02-10 22:06:28 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..0f634bff3 --- /dev/null +++ b/FS/FS/domain_record.pm @@ -0,0 +1,175 @@ +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 record: $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.3 2001-08-21 02:44:47 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. + +=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_bill_event.pm b/FS/FS/part_bill_event.pm new file mode 100644 index 000000000..70c8a56ec --- /dev/null +++ b/FS/FS/part_bill_event.pm @@ -0,0 +1,166 @@ +package FS::part_bill_event; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); +use FS::Conf; + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::part_bill_event - Object methods for part_bill_event records + +=head1 SYNOPSIS + + use FS::part_bill_event; + + $record = new FS::part_bill_event \%hash; + $record = new FS::part_bill_event { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::part_bill_event object represents an invoice event definition - +a callback which is triggered when an invoice is a certain amount of time +overdue. FS::part_bill_event inherits from +FS::Record. The following fields are currently supported: + +=over 4 + +=item eventpart - primary key + +=item payby - CARD, BILL, or COMP + +=item event - event name + +=item eventcode - event action + +=item seconds - how long after the invoice date events of this type are triggered + +=item weight - ordering for events with identical seconds + +=item plan - eventcode plan + +=item plandata - additional plan data + +=item disabled - Disabled flag, empty or `Y' + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new invoice event definition. 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 { 'part_bill_event'; } + +=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 invoice event definition. 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->weight(0) unless $self->weight; + + my $conf = new FS::Conf; + if ( $conf->exists('safe-part_bill_event') ) { + my $error = $self->ut_anything('eventcode'); + return $error if $error; + + my $c = $self->eventcode; + + $c =~ /^\s*\$cust_main\->(suspend|cancel|invoicing_list_addpost|bill|collect)\(\);\s*("";)?\s*$/ + + or $c =~ /^\s*\$cust_bill\->(comp|realtime_card|realtime_card_cybercash|batch_card|send)\(\);\s*$/ + + or $c =~ /^\s*\$cust_main\->apply_payments; \$cust_main->apply_credits; "";\s*$/ + + or $c =~ /^\s*\$cust_main\->charge\( \s*\d*\.?\d*\s*,\s*\'[\w \!\@\#\$\%\&\(\)\-\+\;\:\"\,\.\?\/]*\'\s*\);\s*$/ + + or do { + #log + return "illegal eventcode: $c"; + }; + + } + + $self->ut_numbern('eventpart') + || $self->ut_enum('payby', [qw( CARD BILL COMP )] ) + || $self->ut_text('event') + || $self->ut_anything('eventcode') + || $self->ut_number('seconds') + || $self->ut_enum('disabled', [ '', 'Y' ] ) + || $self->ut_number('weight') + || $self->ut_textn('plan') + || $self->ut_anything('plandata') + ; +} + +=back + +=head1 BUGS + +Alas. + +=head1 SEE ALSO + +L<FS::cust_bill>, L<FS::cust_bill_event>, L<FS::Record>, schema.html from the +base documentation. + +=cut + +1; + diff --git a/FS/FS/part_export.pm b/FS/FS/part_export.pm new file mode 100644 index 000000000..67371bc3b --- /dev/null +++ b/FS/FS/part_export.pm @@ -0,0 +1,138 @@ +package FS::part_export; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); +use FS::part_svc; + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::part_export - Object methods for part_export records + +=head1 SYNOPSIS + + use FS::part_export; + + $record = new FS::part_export \%hash; + $record = new FS::part_export { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::part_export object represents an export of Freeside data to an external +provisioning system. FS::part_export inherits from FS::Record. The following +fields are currently supported: + +=over 4 + +=item eventpart - primary key + +=item svcpart - Service definition (see L<FS::part_svc>) to which this export applies + +=item machine - Machine name + +=item exporttype - Export type + +=item nodomain - blank or "Y" : usernames are exported to this service with no domain + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new export. To add the export 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 { 'part_export'; } + +=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 export. 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('exportnum') + || $self->ut_number('svcpart') + || $self->ut_alpha('exporttype') + ; + return $error if $error; + + return "Unknown svcpart: ". $self->svcpart + unless qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } ); + + $self->machine =~ /^([\w\-\.]*)$/ + or return "Illegal machine: ". $self->machine; + $self->machine($1); + + $self->nodomain =~ /^(Y?)$/ or return "Illegal nodomain: ". $self->nodomain; + $self->nodomain($1); + + #check exporttype? + + ''; #no error +} + +=back + +=head1 BUGS + +Probably. + +=head1 SEE ALSO + +L<FS::part_export_option>, L<FS::part_svc>, L<FS::svc_acct>, L<FS::svc_domain>, +L<FS::svc_forward>, L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/part_export_option.pm b/FS/FS/part_export_option.pm new file mode 100644 index 000000000..4ce70b4cd --- /dev/null +++ b/FS/FS/part_export_option.pm @@ -0,0 +1,134 @@ +package FS::part_export_option; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); +use FS::part_export; + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::part_export_option - Object methods for part_export_option records + +=head1 SYNOPSIS + + use FS::part_export_option; + + $record = new FS::part_export_option \%hash; + $record = new FS::part_export_option { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::part_export_option object represents an export option. +FS::part_export_option inherits from FS::Record. The following fields are +currently supported: + +=over 4 + +=item optionnum - primary key + +=item exportnum - export (see L<FS::part_export>) + +=item option - option name + +=item opeionvalue - option value + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new export option. To add the export option 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 { 'part_export_option'; } + +=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 export option. 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('optionnum') + || $self->ut_number('exportnum') + || $self->ut_alpha('option') + || $self->ut_textn('optionvalue') + ; + return $error if $error; + + return "Unknown exportnum: ". $self->exportnum + unless qsearchs('part_export', { 'exportnum' => $self->exportnum } ); + + #check options & values? + + ''; #no error +} + +=back + +=head1 BUGS + +Possibly. + +=head1 SEE ALSO + +L<FS::part_export>, 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..3d536e7d9 --- /dev/null +++ b/FS/FS/part_pkg.pm @@ -0,0 +1,284 @@ +package FS::part_pkg; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch dbh ); +use FS::pkg_svc; +use FS::agent_type; +use FS::type_pkgs; +use FS::Conf; + +@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 expression + +=item freq - Frequency of recurring fee + +=item recur - Recurring fee expression + +=item setuptax - Setup fee tax exempt flag, empty or `Y' + +=item recurtax - Recurring fee tax exempt flag, empty or `Y' + +=item plan - Price plan + +=item plandata - Price plan data + +=item disabled - Disabled flag, empty or `Y' + +=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. + +=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 $error = $self->SUPER::insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + my $conf = new FS::Conf; + + if ( $conf->exists('agent_defaultpkg') ) { + foreach my $agent_type ( qsearch('agent_type', {} ) ) { + my $type_pkgs = new FS::type_pkgs({ + 'typenum' => $agent_type->typenum, + 'pkgpart' => $self->pkgpart, + }); + my $error = $type_pkgs->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; +} + +=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; + + my $conf = new FS::Conf; + if ( $conf->exists('safe-part_pkg') ) { + + my $error = $self->ut_anything('setup') + || $self->ut_anything('recur'); + return $error if $error; + + my $s = $self->setup; + + $s =~ /^\s*\d*\.?\d*\s*$/ or do { + #log! + return "illegal setup: $s"; + }; + + my $r = $self->recur; + + $r =~ /^\s*\d*\.?\d*\s*$/ + + or $r =~ /^my \$mnow = \$sdate; my \(\$sec,\$min,\$hour,\$mday,\$mon,\$year\) = \(localtime\(\$sdate\) \)\[0,1,2,3,4,5\]; my \$mstart = timelocal\(0,0,0,1,\$mon,\$year\); my \$mend = timelocal\(0,0,0,1, \$mon == 11 \? 0 : \$mon\+1, \$year\+\(\$mon==11\)\); \$sdate = \$mstart; \( \$part_pkg->freq \- 1 \) \* \d*\.?\d* \/ \$part_pkg\-\>freq \+ \d*\.?\d* \/ \$part_pkg\-\>freq \* \(\$mend\-\$mnow\) \/ \(\$mend\-\$mstart\) ;\s*$/ + + or $r =~ /^my \$error = \$cust_pkg\->cust_main\->credit\( \s*\d*\.?\d*\s* \* scalar\(\$cust_pkg\->cust_main\->referral_cust_main_ncancelled\(\s*\d+\s*\)\), "commission" \); die \$error if \$error; \s*\d*\.?\d*\s*;\s*$/ + + or $r =~ /^my \$error = \$cust_pkg\->cust_main\->credit\( \s*\d*\.?\d*\s* \* scalar\(\$cust_pkg\->cust_main->referral_cust_pkg\(\s*\d+\s*\)\), "commission" \); die \$error if \$error; \s*\d*\.?\d*\s*;\s*$/ + + or $r =~ /^my \$error = \$cust_pkg\->cust_main\->credit\( \s*\d*\.?\d*\s* \* scalar\( grep \{ my \$pkgpart = \$_\->pkgpart; grep \{ \$_ == \$pkgpart \} \(\s*(\s*\d+,\s*)*\s*\) \} \$cust_pkg\->cust_main->referral_cust_pkg\(\s*\d+\s*\)\), "commission" \); die \$error if \$error; \s*\d*\.?\d*\s*;\s*$/ + + or $r =~ /^my \$hours = \$cust_pkg\->seconds_since\(\$cust_pkg\->bill \|\| 0\) \/ 3600 \- \s*\d*\.?\d*\s*; \$hours = 0 if \$hours < 0; \s*\d*\.?\d*\s* \+ \s*\d*\.?\d*\s* \* \$hours;\s*$/ + + or $r =~ /^my \$min = \$cust_pkg\->seconds_since\(\$cust_pkg\->bill \|\| 0\) \/ 60 \- \s*\d*\.?\d*\s*; \$min = 0 if \$min < 0; \s*\d*\.?\d*\s* \+ \s*\d*\.?\d*\s* \* \$min;\s*$/ + + or do { + #log! + return "illegal recur: $r"; + }; + + } + + $self->ut_numbern('pkgpart') + || $self->ut_text('pkg') + || $self->ut_text('comment') + || $self->ut_anything('setup') + || $self->ut_number('freq') + || $self->ut_anything('recur') + || $self->ut_alphan('plan') + || $self->ut_anything('plandata') + || $self->ut_enum('setuptax', [ '', 'Y' ] ) + || $self->ut_enum('recurtax', [ '', 'Y' ] ) + || $self->ut_enum('disabled', [ '', 'Y' ] ) + ; +} + +=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.8 2002-02-18 08:39:21 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_pop_local.pm b/FS/FS/part_pop_local.pm new file mode 100644 index 000000000..0b7cdf6c9 --- /dev/null +++ b/FS/FS/part_pop_local.pm @@ -0,0 +1,116 @@ +package FS::part_pop_local; + +use strict; +use vars qw( @ISA ); +use FS::Record; # qw( qsearchs ); + +@ISA = qw( FS::Record ); + +=head1 NAME + +FS::part_pop_local - Object methods for part_pop_local records + +=head1 SYNOPSIS + + use FS::part_pop_local; + + $record = new FS::part_pop_local \%hash; + $record = new FS::part_pop_local { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::part_pop_local object represents a local call area. Each +FS::part_pop_local record maps a NPA/NXX (area code and exchange) to the POP +(see L<FS::svc_acct_pop>) which is a local call. FS::part_pop_local inherits +from FS::Record. The following fields are currently supported: + +=over 4 + +=item localnum - primary key (assigned automatically for new accounts) + +=item popnum - see L<FS::svc_acct_pop> + +=item city + +=item state + +=item npa - area code + +=item nxx - exchange + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new point of presence (if only it were that easy!). To add the +point of presence to the database, see L<"insert">. + +=cut + +sub table { 'part_pop_local'; } + +=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('localnum') + or $self->ut_numbern('popnum') + or $self->ut_text('city') + or $self->ut_text('state') + or $self->ut_number('npa') + or $self->ut_number('nxx') + ; + +} + +=back + +=head1 VERSION + +$Id: part_pop_local.pm,v 1.1 2001-09-26 09:17:06 ivan Exp $ + +=head1 BUGS + +US/CA-centric. + +=head1 SEE ALSO + +L<FS::Record>, L<FS::svc_acct_pop>, 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..41ee21d31 --- /dev/null +++ b/FS/FS/part_svc.pm @@ -0,0 +1,320 @@ +package FS::part_svc; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs fields dbh ); +use FS::part_svc_column; + +@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_svc \%hash + $record = new FS::part_svc { '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_forward>, among others. + +=item disabled - Disabled flag, empty or `Y' + +=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 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 + +=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 $error = $self->SUPER::insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + my $svcdb = $self->svcdb; +# my @rows = map { /^${svcdb}__(.*)$/; $1 } +# grep ! /_flag$/, +# grep /^${svcdb}__/, +# fields('part_svc'); + foreach my $field ( + grep { $_ ne 'svcnum' + && defined( $self->getfield($svcdb.'__'.$_.'_flag') ) + } fields($svcdb) + ) { + my $part_svc_column = $self->part_svc_column($field); + my $previous = qsearchs('part_svc_column', { + 'svcpart' => $self->svcpart, + 'columnname' => $field, + } ); + + my $flag = $self->getfield($svcdb.'__'.$field.'_flag'); + if ( uc($flag) =~ /^([DF])$/ ) { + $part_svc_column->setfield('columnflag', $1); + $part_svc_column->setfield('columnvalue', + $self->getfield($svcdb.'__'.$field) + ); + if ( $previous ) { + $error = $part_svc_column->replace($previous); + } else { + $error = $part_svc_column->insert; + } + } else { + $error = $previous ? $previous->delete : ''; + } + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; +} + +=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 for an existing service definition!" + unless $old->svcdb eq $new->svcdb; + + 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 $error = $new->SUPER::replace( $old ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + if ( @_ && $_[0] eq '1.3-COMPAT' ) { + my $svcdb = $new->svcdb; + foreach my $field ( + grep { $_ ne 'svcnum' + && defined( $new->getfield($svcdb.'__'.$_.'_flag') ) + } fields($svcdb) + ) { + my $part_svc_column = $new->part_svc_column($field); + my $previous = qsearchs('part_svc_column', { + 'svcpart' => $new->svcpart, + 'columnname' => $field, + } ); + + my $flag = $new->getfield($svcdb.'__'.$field.'_flag'); + if ( uc($flag) =~ /^([DF])$/ ) { + $part_svc_column->setfield('columnflag', $1); + $part_svc_column->setfield('columnvalue', + $new->getfield($svcdb.'__'.$field) + ); + if ( $previous ) { + $error = $part_svc_column->replace($previous); + } else { + $error = $part_svc_column->insert; + } + } else { + $error = $previous ? $previous->delete : ''; + } + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + } else { + $dbh->rollback if $oldAutoCommit; + return 'non-1.3-COMPAT interface not yet written'; + #not yet implemented + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; +} + +=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') + || $self->ut_enum('disabled', [ '', 'Y' ] ) + ; + return $error if $error; + + my @fields = eval { fields( $recref->{svcdb} ) }; #might die + return "Unknown svcdb!" unless @fields; + +##REPLACED BY part_svc_column +# 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 +} + +=item part_svc_column COLUMNNAME + +Returns the part_svc_column object (see L<FS::part_svc_column>) for the given +COLUMNNAME, or a new part_svc_column object if none exists. + +=cut + +sub part_svc_column { + my $self = shift; + my $columnname = shift; + qsearchs('part_svc_column', { + 'svcpart' => $self->svcpart, + 'columnname' => $columnname, + } + ) or new FS::part_svc_column { + 'svcpart' => $self->svcpart, + 'columnname' => $columnname, + }; +} + +=item all_part_svc_column + +=cut + +sub all_part_svc_column { + my $self = shift; + qsearch('part_svc_column', { 'svcpart' => $self->svcpart } ); +} + +=back + +=head1 VERSION + +$Id: part_svc.pm,v 1.9 2002-01-28 06:57:23 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_svc_column>, L<FS::part_pkg>, L<FS::pkg_svc>, +L<FS::cust_svc>, L<FS::svc_acct>, L<FS::svc_forward>, L<FS::svc_domain>, +schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/part_svc_column.pm b/FS/FS/part_svc_column.pm new file mode 100644 index 000000000..37e841e87 --- /dev/null +++ b/FS/FS/part_svc_column.pm @@ -0,0 +1,118 @@ +package FS::part_svc_column; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( fields ); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::part_svc_column - Object methods for part_svc_column objects + +=head1 SYNOPSIS + + use FS::part_svc_column; + + $record = new FS::part_svc_column \%hash + $record = new FS::part_svc_column { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::part_svc_column record represents a service definition column +constraint. FS::part_svc_column inherits from FS::Record. The following +fields are currently supported: + +=over 4 + +=item columnnum - primary key (assigned automatcially for new records) + +=item svcpart - service definition (see L<FS::part_svc>) + +=item columnname - column name in part_svc.svcdb table + +=item columnvalue - default or fixed value for the column + +=item columnflag - null, D or F + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new column constraint. To add the column constraint to the database, see L<"insert">. + +=cut + +sub table { 'part_svc_column'; } + +=item insert + +Adds this service definition 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_numbern('columnnum') + || $self->ut_number('svcpart') + || $self->ut_alpha('columnname') + || $self->ut_anything('columnvalue') + ; + return $error if $error; + + $self->columnflag =~ /^([DF])$/ + or return "illegal columnflag ". $self->columnflag; + $self->columnflag(uc($1)); + + ''; #no error +} + +=back + +=head1 VERSION + +$Id: part_svc_column.pm,v 1.1 2001-09-07 20:49:15 ivan Exp $ + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::Record>, L<FS::part_svc>, L<FS::part_pkg>, L<FS::pkg_svc>, +L<FS::cust_svc>, L<FS::svc_acct>, L<FS::svc_forward>, 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..7ed9b8344 --- /dev/null +++ b/FS/FS/prepay_credit.pm @@ -0,0 +1,126 @@ +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', + }; + + $record = new FS::prepay_credit { + 'identifier' => '4198123455512121' + 'seconds' => '7200', + }; + + + $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 + +=item seconds - time amount of credit (see L<FS::svc_acct/seconds>) + +=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') + || $self->utnumbern('seconds') + ; + +} + +=back + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::svc_acct>, L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/queue.pm b/FS/FS/queue.pm new file mode 100644 index 000000000..3260de20d --- /dev/null +++ b/FS/FS/queue.pm @@ -0,0 +1,303 @@ +package FS::queue; + +use strict; +use vars qw( @ISA @EXPORT_OK ); +use Exporter; +use FS::Record qw( qsearch qsearchs dbh ); +#use FS::queue; +use FS::queue_arg; +use FS::cust_svc; + +@ISA = qw(FS::Record); +@EXPORT_OK = qw( joblisting ); + +=head1 NAME + +FS::queue - Object methods for queue records + +=head1 SYNOPSIS + + use FS::queue; + + $record = new FS::queue \%hash; + $record = new FS::queue { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::queue object represents an queued job. FS::queue inherits from +FS::Record. The following fields are currently supported: + +=over 4 + +=item jobnum - primary key + +=item job - fully-qualified subroutine name + +=item status - job status + +=item statustext - freeform text status message + +=item _date - UNIX timestamp + +=item svcnum - optional link to service (see L<FS::cust_svc>) + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new job. 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 { 'queue'; } + +=item insert [ ARGUMENT, ARGUMENT... ] + +Adds this record to the database. If there is an error, returns the error, +otherwise returns false. + +If any arguments are supplied, a queue_arg record for each argument is also +created (see L<FS::queue_arg>). + +=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 $error = $self->SUPER::insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + foreach my $arg ( @_ ) { + my $queue_arg = new FS::queue_arg ( { + 'jobnum' => $self->jobnum, + 'arg' => $arg, + } ); + $error = $queue_arg->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; + +} + +=item delete + +Delete this record from the database. Any corresponding queue_arg records are +deleted as well + +=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; + + my @args = qsearch( 'queue_arg', { 'jobnum' => $self->jobnum } ); + + my $error = $self->SUPER::delete; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + foreach my $arg ( @args ) { + $error = $arg->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. + +=cut + +# the replace method can be inherited from FS::Record + +=item check + +Checks all fields to make sure this is a valid job. 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('jobnum') + || $self->ut_anything('job') + || $self->ut_numbern('_date') + || $self->ut_enum('status',['', qw( new locked failed )]) + || $self->ut_textn('statustext') + || $self->ut_numbern('svcnum') + ; + return $error if $error; + + $error = $self->ut_foreign_keyn('svcnum', 'cust_svc', 'svcnum'); + $self->svcnum('') if $error; + + $self->status('new') unless $self->status; + $self->_date(time) unless $self->_date; + + ''; #no error +} + +=item args + +=cut + +sub args { + my $self = shift; + map $_->arg, qsearch( 'queue_arg', + { 'jobnum' => $self->jobnum }, + '', + 'ORDER BY argnum' + ); +} + +=item cust_svc + +Returns the FS::cust_svc object associated with this job, if any. + +=cut + +sub cust_svc { + my $self = shift; + qsearchs('cust_svc', { 'svcnum' => $self->svcnum } ); +} + +=item joblisting HASHREF + +=cut + +sub joblisting { + my($hashref, $noactions) = @_; + + use Date::Format; + use FS::CGI; + + my $html = FS::CGI::table(). <<END; + <TR> + <TH COLSPAN=2>Job</TH> + <TH>Args</TH> + <TH>Date</TH> + <TH>Status</TH> + <TH>Account</TH> + </TR> +END + + my $p = FS::CGI::popurl(2); + foreach my $queue ( sort { + $a->getfield('jobnum') <=> $b->getfield('jobnum') + } qsearch( 'queue', $hashref ) ) { + my $hashref = $queue->hashref; + my $jobnum = $queue->jobnum; + my $args = join(' ', $queue->args); + my $date = time2str( "%a %b %e %T %Y", $queue->_date ); + my $status = $queue->status; + $status .= ': '. $queue->statustext if $queue->statustext; + if ( ! $noactions && $status =~ /^failed/ || $status =~ /^locked/ ) { + $status .= + qq! ( <A HREF="$p/misc/queue.cgi?jobnum=$jobnum&action=new">retry</A> |!. + qq! <A HREF="$p/misc/queue.cgi?jobnum=$jobnum&action=del">remove</A> )!; + } + my $cust_svc = $queue->cust_svc; + my $account; + if ( $cust_svc ) { + my $table = $cust_svc->part_svc->svcdb; + my $label = ( $cust_svc->label )[1]; + $account = qq!<A HREF="../view/$table.cgi?!. $queue->svcnum. + qq!">$label</A>!; + } else { + $account = ''; + } + $html .= <<END; + <TR> + <TD>$jobnum</TD> + <TD>$hashref->{job}</TD> + <TD>$args</TD> + <TD>$date</TD> + <TD>$status</TD> + <TD>$account</TD> + </TR> +END + +} + + $html .= '</TABLE>'; + + $html; + +} + +=back + +=head1 VERSION + +$Id: queue.pm,v 1.6 2002-02-22 06:42:28 ivan Exp $ + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/queue_arg.pm b/FS/FS/queue_arg.pm new file mode 100644 index 000000000..08fe47341 --- /dev/null +++ b/FS/FS/queue_arg.pm @@ -0,0 +1,121 @@ +package FS::queue_arg; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::queue_arg - Object methods for queue_arg records + +=head1 SYNOPSIS + + use FS::queue_arg; + + $record = new FS::queue_arg \%hash; + $record = new FS::queue_arg { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::queue_arg object represents job argument. FS::queue_arg inherits from +FS::Record. The following fields are currently supported: + +=over 4 + +=item argnum - primary key + +=item jobnum - see L<FS::queue> + +=item arg - argument + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new argument. 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 { 'queue_arg'; } + +=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 argument. 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('argnum') + || $self->ut_numbern('jobnum') + || $self->ut_anything('arg') + ; + return $error if $error; + + ''; #no error +} + +=back + +=head1 VERSION + +$Id: queue_arg.pm,v 1.1 2001-09-11 00:08:18 ivan Exp $ + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::queue>, L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/raddb.pm b/FS/FS/raddb.pm new file mode 100644 index 000000000..04389c91b --- /dev/null +++ b/FS/FS/raddb.pm @@ -0,0 +1,1086 @@ +package FS::raddb; +use vars qw(%attrib); + +%attrib = ( + 'ascend_bi_directional_au' => 'Ascend-Bi-Directional-Auth', + 'h323_connect_time' => 'h323-connect-time', + 'connect_rate' => 'Connect-Rate', + 'bind_auth_service_grp' => 'Bind_Auth_Service_Grp', + 'usr_callback_type' => 'USR-Callback-Type', + 'erx_primary_wins' => 'ERX-Primary-Wins', + 'ascend_x25_x121_address' => 'Ascend-X25-X121-Address', + 'usr_log_filter_packets' => 'USR-Log-Filter-Packets', + 'annex_addr_resolution_pr' => 'Annex-Addr-Resolution-Protocol', + 'usr_ip_rip_simple_auth_p' => 'USR-IP-RIP-Simple-Auth-Password', + 'dialback_name' => 'Dialback-Name', + 'x_ascend_fr_dce_n392' => 'X-Ascend-FR-DCE-N392', + 'usr_host_type' => 'USR-Host-Type', + 'le_modem_info' => 'LE-Modem-Info', + 'x_ascend_menu_selector' => 'X-Ascend-Menu-Selector', + 'x_ascend_fr_dce_n393' => 'X-Ascend-FR-DCE-N393', + 'ascend_ip_direct' => 'Ascend-IP-Direct', + 'x_ascend_pre_output_octe' => 'X-Ascend-Pre-Output-Octets', + 'x_ascend_ft1_caller' => 'X-Ascend-FT1-Caller', + 'usr_last_callers_number_' => 'USR-Last-Callers-Number-ANI', + 'usr_rmmie_product_code' => 'USR-RMMIE-Product-Code', + 'usr_igmp_robustness' => 'USR-IGMP-Robustness', + 'ms_chap2_success' => 'MS-CHAP2-Success', + 'ascend_home_agent_passwo' => 'Ascend-Home-Agent-Password', + 'acc_bridging_support' => 'Acc-Bridging-Support', + 'annex_transmit_speed' => 'Annex-Transmit-Speed', + 'old_password' => 'Old-Password', + 'x_ascend_metric' => 'X-Ascend-Metric', + 'acc_clearing_location' => 'Acc-Clearing-Location', + 'ascend_multilink_id' => 'Ascend-Multilink-ID', + 'ascend_egress_enabled' => 'Ascend-Egress-Enabled', + 'usr_bridging' => 'USR-Bridging', + 'ascend_assign_ip_server' => 'Ascend-Assign-IP-Server', + 'acc_dns_server_sec' => 'Acc-Dns-Server-Sec', + 'ascend_home_agent_ip_add' => 'Ascend-Home-Agent-IP-Addr', + 'usr_dnis_reauthenticatio' => 'USR-DNIS-ReAuthentication', + 'acc_modem_error_protocol' => 'Acc-Modem-Error-Protocol', + 'ascend_backup' => 'Ascend-Backup', + 'usr_connect_time' => 'USR-Connect-Time', + 'ascend_cbcp_mode' => 'Ascend-CBCP-Mode', + 'usr_rmmie_x2_status' => 'USR-RMMIE-x2-Status', + 'ascend_multicast_gleave_' => 'Ascend-Multicast-GLeave-Delay', + 'erx_ingress_statistics' => 'ERX-Ingress-Statistics', + 'cisco_nas_port' => 'Cisco-NAS-Port', + 'le_admin_group' => 'LE-Admin-Group', + 'annex_mrru' => 'Annex-MRRU', + 'x_ascend_add_seconds' => 'X-Ascend-Add-Seconds', + 'ascend_token_expiry' => 'Ascend-Token-Expiry', + 'usr_igmp_maximum_respons' => 'USR-IGMP-Maximum-Response-Time', + 'ascend_calling_id_presen' => 'Ascend-Calling-Id-Presentatn', + 'connect_info' => 'Connect-Info', + 'ascend_access_intercept_' => 'Ascend-Access-Intercept-LEA', + 'x_ascend_dba_monitor' => 'X-Ascend-DBA-Monitor', + 'client_dns_pri' => 'Client_DNS_Pri', + 'ip_host_addr' => 'Ip_Host_Addr', + 'callback_id' => 'Callback-Id', + 'acct_mcast_out_octets' => 'Acct_Mcast_Out_Octets', + 'acct_input_octets_64' => 'Acct_Input_Octets_64', + 'tunnel_function' => 'Tunnel_Function', + 'ascend_fr_direct_profile' => 'Ascend-FR-Direct-Profile', + 'h323_incoming_conf_id' => 'h323-incoming-conf-id', + 'ascend_ppp_vj_1172' => 'Ascend-PPP-VJ-1172', + 'ms_new_arap_password' => 'MS-New-ARAP-Password', + 'h323_voice_quality' => 'h323-voice-quality', + 'framed_appletalk_network' => 'Framed-AppleTalk-Network', + 'bind_int_interface_name' => 'Bind_Int_Interface_Name', + 'event_timestamp' => 'Event-Timestamp', + 'ascend_bir_enable' => 'Ascend-BIR-Enable', + 'usr_fallback_enabled' => 'USR-Fallback-Enabled', + 'ascend_dhcp_pool_number' => 'Ascend-DHCP-Pool-Number', + 'acct_session_id' => 'Acct-Session-Id', + 'ascend_private_route_req' => 'Ascend-Private-Route-Required', + 'usr_rmmie_pwrlvl_farecho' => 'USR-RMMIE-PwrLvl-FarEcho-Canc', + 'usr_at_input_filter' => 'USR-AT-Input-Filter', + 'erx_egress_statistics' => 'ERX-Egress-Statistics', + 'x_ascend_call_type' => 'X-Ascend-Call-Type', + 'acct_tunnel_client_endpo' => 'Acct-Tunnel-Client-Endpoint', + 'x_ascend_assign_ip_clien' => 'X-Ascend-Assign-IP-Client', + 'ascend_if_netmask' => 'Ascend-IF-Netmask', + 'ascend_dhcp_maximum_leas' => 'Ascend-DHCP-Maximum-Leases', + 'usr_at_output_filter' => 'USR-AT-Output-Filter', + 'usr_rad_dvmrp_metric' => 'USR-Rad-Dvmrp-Metric', + 'rate_limit_rate' => 'Rate_Limit_Rate', + 'prefix' => 'Prefix', + 'ascend_x25_pad_banner' => 'Ascend-X25-Pad-Banner', + 'usr_rmmie_rcv_pwrlvl_375' => 'USR-RMMIE-Rcv-PwrLvl-3750Hz', + 'x_ascend_user_acct_key' => 'X-Ascend-User-Acct-Key', + 'group_name' => 'Group-Name', + 'ascend_receive_secret' => 'Ascend-Receive-Secret', + 'reply_message' => 'Reply-Message', + 'le_nat_sess_dir_fail_act' => 'LE-NAT-Sess-Dir-Fail-Action', + 'framed_callback_id' => 'Framed-Callback-Id', + 'cisco_disconnect_cause' => 'Cisco-Disconnect-Cause', + 'stripped_user_name' => 'Stripped-User-Name', + 'annex_keypress_timeout' => 'Annex-Keypress-Timeout', + 'annex_receive_speed' => 'Annex-Receive-Speed', + 'ms_chap_domain' => 'MS-CHAP-Domain', + 'ascend_atm_connect_group' => 'Ascend-ATM-Connect-Group', + 'usr_send_name' => 'USR-Send-Name', + 'usr_local_framed_ip_addr' => 'USR-Local-Framed-IP-Addr', + 'erx_alternate_cli_vroute' => 'ERX-Alternate-Cli-Vrouter-Name', + 'usr_fallback_limit' => 'USR-Fallback-Limit', + 'ascend_pri_number_type' => 'Ascend-PRI-Number-Type', + 'x_ascend_minimum_channel' => 'X-Ascend-Minimum-Channels', + 'x_ascend_fr_direct_dlci' => 'X-Ascend-FR-Direct-DLCI', + 'ascend_fr_link_mgt' => 'Ascend-FR-Link-Mgt', + 'annex_host_allow' => 'Annex-Host-Allow', + 'x_ascend_force_56' => 'X-Ascend-Force-56', + 'police_burst' => 'Police_Burst', + 'pvc_profile_name' => 'PVC_Profile_Name', + 'ms_filter' => 'MS-Filter', + 'rate_limit_burst' => 'Rate_Limit_Burst', + 'ascend_number_sessions' => 'Ascend-Number-Sessions', + 'cisco_call_filter' => 'Cisco-Call-Filter', + 'erx_igmp_enable' => 'ERX-Igmp-Enable', + 'ascend_filter_required' => 'Ascend-Filter-Required', + 'erx_cli_allow_all_vr_acc' => 'ERX-Cli-Allow-All-VR-Access', + 'acc_callback_delay' => 'Acc-Callback-Delay', + 'usr_default_dte_data_rat' => 'USR-Default-DTE-Data-Rate', + 'le_ip_pool' => 'LE-IP-Pool', + 'cisco_pre_output_packets' => 'Cisco-Pre-Output-Packets', + 'x_ascend_group' => 'X-Ascend-Group', + 'usr_channel_connected_to' => 'USR-Channel-Connected-To', + 'usr_ipx_rip_output_filte' => 'USR-IPX-RIP-Output-Filter', + 'usr_esn' => 'USR-ESN', + 'annex_user_level' => 'Annex-User-Level', + 'x_ascend_primary_home_ag' => 'X-Ascend-Primary-Home-Agent', + 'no_such_attribute' => 'No-Such-Attribute', + 'x_ascend_pri_number_type' => 'X-Ascend-PRI-Number-Type', + 'ms_mppe_send_key' => 'MS-MPPE-Send-Key', + 'usr_actual_voltage' => 'USR-Actual-Voltage', + 'annex_acct_servers' => 'Annex-Acct-Servers', + 'ascend_handle_ipx' => 'Ascend-Handle-IPX', + 'cisco_xmit_rate' => 'Cisco-Xmit-Rate', + 'acc_service_profile' => 'Acc-Service-Profile', + 'x_ascend_ara_pw' => 'X-Ascend-Ara-PW', + 'ascend_ckt_type' => 'Ascend-Ckt-Type', + 'cisco_data_rate' => 'Cisco-Data-Rate', + 'group' => 'Group', + 'nas_port' => 'NAS-Port', + 'usr_ipx_call_output_filt' => 'USR-IPX-Call-Output-Filter', + 'tunnel_type' => 'Tunnel-Type', + 'usr_rmmie_manufacturer_i' => 'USR-RMMIE-Manufacturer-ID', + 'user_name_is_star' => 'User-Name-Is-Star', + 'usr_call_arrival_in_gmt' => 'USR-Call-Arrival-in-GMT', + 'x_ascend_number_sessions' => 'X-Ascend-Number-Sessions', + 'ascend_send_auth' => 'Ascend-Send-Auth', + 'user_service_type' => 'User-Service-Type', + 'annex_cli_filter' => 'Annex-CLI-Filter', + 'erx_cli_initial_access_l' => 'ERX-Cli-Initial-Access-Level', + 'ascend_call_direction' => 'Ascend-Call-Direction', + 'usr_chassis_temp_thresho' => 'USR-Chassis-Temp-Threshold', + 'usr_pw_usr_ofilter_ipx' => 'USR-PW_USR_OFilter_IPX', + 'tunnel_session_auth' => 'Tunnel_Session_Auth', + 'x_ascend_connect_progres' => 'X-Ascend-Connect-Progress', + 'ascend_atm_connect_vci' => 'Ascend-ATM-Connect-Vci', + 'x_ascend_maximum_call_du' => 'X-Ascend-Maximum-Call-Duration', + 'usr_rmmie_planned_discon' => 'USR-RMMIE-Planned-Disconnect', + 'x_ascend_fr_dte_n392' => 'X-Ascend-FR-DTE-N392', + 'login_host' => 'Login-Host', + 'ascend_user_acct_host' => 'Ascend-User-Acct-Host', + 'x_ascend_fr_dte_n393' => 'X-Ascend-FR-DTE-N393', + 'acc_tunnel_secret' => 'Acc-Tunnel-Secret', + 'usr_at_rtmp_input_filter' => 'USR-AT-RTMP-Input-Filter', + 'framed_protocol' => 'Framed-Protocol', + 'login_callback_number' => 'Login-Callback-Number', + 'ascend_dsl_rate_type' => 'Ascend-Dsl-Rate-Type', + 'ascend_pre_output_packet' => 'Ascend-Pre-Output-Packets', + 'proxy_state' => 'Proxy-State', + 'usr_pw_usr_ofilter_ip' => 'USR-PW_USR_OFilter_IP', + 'cisco_data_filter' => 'Cisco-Data-Filter', + 'cisco_target_util' => 'Cisco-Target-Util', + 'usr_ids0_call_type' => 'USR-IDS0-Call-Type', + 'usr_blocks_resent' => 'USR-Blocks-Resent', + 'usr_terminal_type' => 'USR-Terminal-Type', + 'ascend_history_weigh_typ' => 'Ascend-History-Weigh-Type', + 'framed_routing' => 'Framed-Routing', + 'ascend_client_assign_dns' => 'Ascend-Client-Assign-DNS', + 'ascend_atm_group' => 'Ascend-ATM-Group', + 'bind_bypass_bypass' => 'Bind_Bypass_Bypass', + 'le_ip_gateway' => 'LE-IP-Gateway', + 'cisco_ip_pool_definition' => 'Cisco-IP-Pool-Definition', + 'x_ascend_maximum_time' => 'X-Ascend-Maximum-Time', + 'usr_request_type' => 'USR-Request-Type', + 'usr_call_arrival_time' => 'USR-Call-Arrival-Time', + 'tunnel_domain' => 'Tunnel_Domain', + 'ms_chap_nt_enc_pw' => 'MS-CHAP-NT-Enc-PW', + 'shiva_calling_number' => 'Shiva-Calling-Number', + 'ip_address_pool_name' => 'Ip_Address_Pool_Name', + 'erx_secondary_dns' => 'ERX-Secondary-Dns', + 'x_ascend_pre_input_octet' => 'X-Ascend-Pre-Input-Octets', + 'ascend_home_agent_udp_po' => 'Ascend-Home-Agent-UDP-Port', + 'le_nat_outsource_inmap' => 'LE-NAT-Outsource-Inmap', + 'x_ascend_home_agent_pass' => 'X-Ascend-Home-Agent-Password', + 'tunnel_password' => 'Tunnel-Password', + 'usr_compression_type' => 'USR-Compression-Type', + 'usr_connect_speed' => 'USR-Connect-Speed', + 'usr_connect_time_limit' => 'USR-Connect-Time-Limit', + 'arap_challenge_response' => 'ARAP-Challenge-Response', + 'ms_link_utilization_thre' => 'MS-Link-Utilization-Threshold', + 'usr_mp_edo' => 'USR-MP-EDO', + 'usr_primary_nbns_server' => 'USR-Primary_NBNS_Server', + 'usr_imsi' => 'USR-IMSI', + 'ascend_fr_direct' => 'Ascend-FR-Direct', + 'ascend_vrouter_name' => 'Ascend-VRouter-Name', + 'ascend_preempt_limit' => 'Ascend-Preempt-Limit', + 'ascend_ip_pool_definitio' => 'Ascend-IP-Pool-Definition', + 'h323_gw_id' => 'h323-gw-id', + 'usr_framed_ipx_route' => 'USR-Framed-IPX-Route', + 'x_ascend_maximum_channel' => 'X-Ascend-Maximum-Channels', + 'login_lat_node' => 'Login-LAT-Node', + 'acct_session_time' => 'Acct-Session-Time', + 'ascend_disconnect_cause' => 'Ascend-Disconnect-Cause', + 'ms_mppe_encryption_polic' => 'MS-MPPE-Encryption-Policy', + 'ms_ras_version' => 'MS-RAS-Version', + 'class' => 'Class', + 'caller_id' => 'Caller-ID', + 'ascend_access_intercept_' => 'Ascend-Access-Intercept-Log', + 'ascend_service_type' => 'Ascend-Service-Type', + 'ascend_h323_dialed_time' => 'Ascend-H323-Dialed-Time', + 'exec_program_wait' => 'Exec-Program-Wait', + 'ascend_x25_nui_password_' => 'Ascend-X25-Nui-Password-Prompt', + 'ascend_appletalk_peer_mo' => 'Ascend-Appletalk-Peer-Mode', + 'login_lat_group' => 'Login-LAT-Group', + 'strip_user_name' => 'Strip-User-Name', + 'nas_ip_address' => 'NAS-IP-Address', + 'ascend_maximum_time' => 'Ascend-Maximum-Time', + 'erx_atm_pcr' => 'ERX-Atm-PCR', + 'ascend_client_primary_dn' => 'Ascend-Client-Primary-DNS', + 'auth_type' => 'Auth-Type', + 'ascend_secondary_home_ag' => 'Ascend-Secondary-Home-Agent', + 'x_ascend_idle_limit' => 'X-Ascend-Idle-Limit', + 'ms_ras_vendor' => 'MS-RAS-Vendor', + 'ascend_pre_input_packets' => 'Ascend-Pre-Input-Packets', + 'ascend_bridge' => 'Ascend-Bridge', + 'h323_redirect_number' => 'h323-redirect-number', + 'usr_simplified_mnp_level' => 'USR-Simplified-MNP-Levels', + 'annex_edo' => 'Annex-EDO', + 'acc_nbns_server_sec' => 'Acc-Nbns-Server-Sec', + 'ascend_cbcp_trunk_group' => 'Ascend-CBCP-Trunk-Group', + 'x_ascend_data_svc' => 'X-Ascend-Data-Svc', + 'le_terminate_detail' => 'LE-Terminate-Detail', + 'acct_output_octets' => 'Acct-Output-Octets', + 'usr_calling_party_number' => 'USR-Calling-Party-Number', + 'x_ascend_dhcp_maximum_le' => 'X-Ascend-DHCP-Maximum-Leases', + 'ascend_force_56' => 'Ascend-Force-56', + 'shiva_acct_serv_switch' => 'Shiva-Acct-Serv-Switch', + 'tunnel_algorithm' => 'Tunnel_Algorithm', + 'usr_max_channels' => 'USR-Max-Channels', + 'usr_port_tap_priority' => 'USR-Port-Tap-Priority', + 'le_nat_outmap' => 'LE-NAT-Outmap', + 'usr_call_connecting_time' => 'USR-Call-Connecting-Time', + 'usr_supports_tags' => 'USR-Supports-Tags', + 'idle_timeout' => 'Idle-Timeout', + 'usr_ip_rip_input_filter' => 'USR-IP-RIP-Input-Filter', + 'erx_ingress_policy_name' => 'ERX-Ingress-Policy-Name', + 'usr_pw_cutoff' => 'USR-PW_Cutoff', + 'usr_channel_expansion' => 'USR-Channel-Expansion', + 'x_ascend_send_secret' => 'X-Ascend-Send-Secret', + 'h323_call_origin' => 'h323-call-origin', + 'h323_preferred_lang' => 'h323-preferred-lang', + 'ascend_base_channel_coun' => 'Ascend-Base-Channel-Count', + 'bind_auth_context' => 'Bind_Auth_Context', + 'ascend_calling_id_number' => 'Ascend-Calling-Id-Number-Plan', + 'ascend_modem_shelfno' => 'Ascend-Modem-ShelfNo', + 'tunnel_police_burst' => 'Tunnel_Police_Burst', + 'pvc_circuit_padding' => 'PVC_Circuit_Padding', + 'acc_ml_call_threshold' => 'Acc-ML-Call-Threshold', + 'usr_end_time' => 'USR-End-Time', + 'usr_ipx' => 'USR-IPX', + 'ms_primary_dns_server' => 'MS-Primary-DNS-Server', + 'ascend_dsl_upstream_limi' => 'Ascend-Dsl-Upstream-Limit', + 'usr_blocks_sent' => 'USR-Blocks-Sent', + 'bind_dot1q_vlan_tag_id' => 'Bind_Dot1q_Vlan_Tag_Id', + 'ascend_private_route' => 'Ascend-Private-Route', + 'usr_back_channel_data_ra' => 'USR-Back-Channel-Data-Rate', + 'ascend_dropped_packets' => 'Ascend-Dropped-Packets', + 'cisco_route_ip' => 'Cisco-Route-IP', + 'nas_identifier' => 'NAS-Identifier', + 'ascend_presession_time' => 'Ascend-PreSession-Time', + 'usr_call_type' => 'USR-Call-Type', + 'usr_acct_reason_code' => 'USR-Acct-Reason-Code', + 'acc_dialout_auth_passwor' => 'Acc-Dialout-Auth-Password', + 'acc_connect_tx_speed' => 'Acc-Connect-Tx-Speed', + 'cisco_pre_input_octets' => 'Cisco-Pre-Input-Octets', + 'x_ascend_send_passwd' => 'X-Ascend-Send-Passwd', + 'ascend_bir_bridge_group' => 'Ascend-BIR-Bridge-Group', + 'ascend_fr_profile_name' => 'Ascend-FR-Profile-Name', + 'ascend_group' => 'Ascend-Group', + 'crypt_password' => 'Crypt-Password', + 'usr_port_tap_address' => 'USR-Port-Tap-Address', + 'le_nat_outsource_outmap' => 'LE-NAT-Outsource-Outmap', + 'usr_vpn_encrypter' => 'USR-VPN-Encrypter', + 'usr_blocks_received' => 'USR-Blocks-Received', + 'tunnel_group' => 'Tunnel_Group', + 'ascend_shared_profile_en' => 'Ascend-Shared-Profile-Enable', + 'replicate_to_realm' => 'Replicate-To-Realm', + 'usr_mobile_ip_address' => 'USR-Mobile-IP-Address', + 'x_ascend_authen_alias' => 'X-Ascend-Authen-Alias', + 'ascend_fr_linkup' => 'Ascend-FR-LinkUp', + 'tunnel_rate_limit_rate' => 'Tunnel_Rate_Limit_Rate', + 'acc_access_community' => 'Acc-Access-Community', + 'x_ascend_presession_time' => 'X-Ascend-PreSession-Time', + 'ms_chap_cpw_1' => 'MS-CHAP-CPW-1', + 'ms_chap_cpw_2' => 'MS-CHAP-CPW-2', + 'erx_primary_dns' => 'ERX-Primary-Dns', + 'ascend_fr_circuit_name' => 'Ascend-FR-Circuit-Name', + 'ascend_token_immediate' => 'Ascend-Token-Immediate', + 'cisco_idle_limit' => 'Cisco-Idle-Limit', + 'usr_speed_of_connection' => 'USR-Speed-Of-Connection', + 'shiva_links_in_bundle' => 'Shiva-Links-In-Bundle', + 'x_ascend_fr_profile_name' => 'X-Ascend-FR-Profile-Name', + 'cisco_multilink_id' => 'Cisco-Multilink-ID', + 'x_ascend_preempt_limit' => 'X-Ascend-Preempt-Limit', + 'ascend_assign_ip_client' => 'Ascend-Assign-IP-Client', + 'usr_iwf_ip_address' => 'USR-IWF-IP-Address', + 'acct_unique_session_id' => 'Acct-Unique-Session-Id', + 'framed_pool' => 'Framed-Pool', + 'usr_igmp_version' => 'USR-IGMP-Version', + 'tunnel_max_tunnels' => 'Tunnel_Max_Tunnels', + 'annex_unauthenticated_ti' => 'Annex-Unauthenticated-Time', + 'bg_path_cost' => 'BG_Path_Cost', + 'ascend_client_assign_win' => 'Ascend-Client-Assign-WINS', + 'x_ascend_dial_number' => 'X-Ascend-Dial-Number', + 'cisco_maximum_channels' => 'Cisco-Maximum-Channels', + 'usr_pw_framed_routing_v2' => 'USR-PW_Framed_Routing_V2', + 'usr_channel_decrement' => 'USR-Channel-Decrement', + 'x_ascend_route_ipx' => 'X-Ascend-Route-IPX', + 'port_limit' => 'Port-Limit', + 'ascend_dsl_downstream_li' => 'Ascend-Dsl-Downstream-Limit', + 'ascend_ip_tos_precedence' => 'Ascend-IP-TOS-Precedence', + 'usr_multicast_receive' => 'USR-Multicast-Receive', + 'usr_auth_mode' => 'USR-Auth-Mode', + 'expiration' => 'Expiration', + 'x_ascend_fr_circuit_name' => 'X-Ascend-FR-Circuit-Name', + 'x_ascend_token_immediate' => 'X-Ascend-Token-Immediate', + 'ascend_ft1_caller' => 'Ascend-FT1-Caller', + 'shiva_event_flags' => 'Shiva-Event-Flags', + 'framed_netmask' => 'Framed-Netmask', + 'ascend_minimum_channels' => 'Ascend-Minimum-Channels', + 'acc_ml_damping_factor' => 'Acc-ML-Damping-Factor', + 'bind_sub_password' => 'Bind_Sub_Password', + 'ascend_ip_tos_apply_to' => 'Ascend-IP-TOS-Apply-To', + 'x_ascend_home_agent_udp_' => 'X-Ascend-Home-Agent-UDP-Port', + 'x_ascend_menu_item' => 'X-Ascend-Menu-Item', + 'ascend_session_type' => 'Ascend-Session-Type', + 'usr_pw_packet' => 'USR-PW_Packet', + 'session' => 'Session', + 'usr_mic' => 'USR-MIC', + 'usr_line_reversals' => 'USR-Line-Reversals', + 'assigned_ip_address' => 'Assigned_IP_Address', + 'cisco_ip_direct' => 'Cisco-IP-Direct', + 'le_ipsec_log_options' => 'LE-IPSec-Log-Options', + 'tunnel_rate_limit_burst' => 'Tunnel_Rate_Limit_Burst', + 'x_ascend_assign_ip_globa' => 'X-Ascend-Assign-IP-Global-Pool', + 'x_ascend_inc_channel_cou' => 'X-Ascend-Inc-Channel-Count', + 'h323_return_code' => 'h323-return-code', + 'shiva_disconnect_reason' => 'Shiva-Disconnect-Reason', + 'filter_id' => 'Filter-Id', + 'usr_appletalk_network_ra' => 'USR-Appletalk-Network-Range', + 'ascend_temporary_rtes' => 'Ascend-Temporary-Rtes', + 'ascend_h323_conference_i' => 'Ascend-H323-Conference-Id', + 'h323_billing_model' => 'h323-billing-model', + 'usr_bearer_capabilities' => 'USR-Bearer-Capabilities', + 'framed_appletalk_zone' => 'Framed-AppleTalk-Zone', + 'usr_harc_disconnect_code' => 'USR-HARC-Disconnect-Code', + 'usr_ipx_rip_input_filter' => 'USR-IPX-RIP-Input-Filter', + 'usr_rad_multicast_routin' => 'USR-Rad-Multicast-Routing-Bound', + 'ascend_pw_lifetime' => 'Ascend-PW-Lifetime', + 'acc_dialout_auth_usernam' => 'Acc-Dialout-Auth-Username', + 'ascend_x25_pad_x3_parame' => 'Ascend-X25-Pad-X3-Parameters', + 'bind_dot1q_slot' => 'Bind_Dot1q_Slot', + 'usr_rad_multicast_routin' => 'USR-Rad-Multicast-Routing-RtLim', + 'x_ascend_multicast_clien' => 'X-Ascend-Multicast-Client', + 'ascend_authen_alias' => 'Ascend-Authen-Alias', + 'ascend_dec_channel_count' => 'Ascend-Dec-Channel-Count', + 'dhcp_max_leases' => 'DHCP_Max_Leases', + 'shiva_called_number' => 'Shiva-Called-Number', + 'annex_tunnel_authen_mode' => 'Annex-Tunnel-Authen-Mode', + 'usr_call_error_code' => 'USR-Call-Error-Code', + 'x_ascend_user_acct_type' => 'X-Ascend-User-Acct-Type', + 'ascend_atm_connect_vpi' => 'Ascend-ATM-Connect-Vpi', + 'ascend_x25_pad_x3_profil' => 'Ascend-X25-Pad-X3-Profile', + 'usr_mobileip_home_agent_' => 'USR-MobileIP-Home-Agent-Address', + 'suffix' => 'Suffix', + 'bind_tun_context' => 'Bind_Tun_Context', + 'x_ascend_ppp_address' => 'X-Ascend-PPP-Address', + 'usr_dtr_false_timeout' => 'USR-DTR-False-Timeout', + 'usr_final_rx_link_data_r' => 'USR-Final-Rx-Link-Data-Rate', + 'ms_chap_error' => 'MS-CHAP-Error', + 'x_ascend_home_agent_ip_a' => 'X-Ascend-Home-Agent-IP-Addr', + 'ascend_data_svc' => 'Ascend-Data-Svc', + 'usr_rmmie_pwrlvl_noise_l' => 'USR-RMMIE-PwrLvl-Noise-Lvl', + 'usr_dtr_true_timeout' => 'USR-DTR-True-Timeout', + 'context_name' => 'Context-Name', + 'usr_card_type' => 'USR-Card-Type', + 'ascend_fr_link_status_dl' => 'Ascend-FR-Link-Status-DLCI', + 'annex_sec_profile_index' => 'Annex-Sec-Profile-Index', + 'usr_pw_usr_ofilter_sap' => 'USR-PW_USR_OFilter_SAP', + 'tunnel_medium_type' => 'Tunnel-Medium-Type', + 'x_ascend_require_auth' => 'X-Ascend-Require-Auth', + 'ascend_connect_progress' => 'Ascend-Connect-Progress', + 'x_ascend_modem_shelfno' => 'X-Ascend-Modem-ShelfNo', + 'cisco_pre_input_packets' => 'Cisco-Pre-Input-Packets', + 'ascend_fr_dce_n392' => 'Ascend-FR-DCE-N392', + 'ascend_fr_dce_n393' => 'Ascend-FR-DCE-N393', + 'ascend_client_primary_wi' => 'Ascend-Client-Primary-WINS', + 'shiva_link_protocol' => 'Shiva-Link-Protocol', + 'bridge_group' => 'Bridge_Group', + 'client_port_dnis' => 'Client-Port-DNIS', + 'usr_mpip_tunnel_originat' => 'USR-MPIP-Tunnel-Originator', + 'le_nat_log_options' => 'LE-NAT-Log-Options', + 'usr_number_of_rings_limi' => 'USR-Number-of-Rings-Limit', + 'usr_retrains_granted' => 'USR-Retrains-Granted', + 'acc_ip_gateway_pri' => 'Acc-Ip-Gateway-Pri', + 'usr_number_of_fallbacks' => 'USR-Number-of-Fallbacks', + 'usr_tunnel_auth_hostname' => 'USR-Tunnel-Auth-Hostname', + 'annex_filter' => 'Annex-Filter', + 'ascend_mtu' => 'Ascend-MTU', + 'ms_arap_pw_change_reason' => 'MS-ARAP-PW-Change-Reason', + 'private_group_id' => 'Private-Group-Id', + 'ascend_cache_time' => 'Ascend-Cache-Time', + 'acc_ml_clear_threshold' => 'Acc-ML-Clear-Threshold', + 'x_ascend_dhcp_reply' => 'X-Ascend-DHCP-Reply', + 'ascend_h323_gatekeeper' => 'Ascend-H323-Gatekeeper', + 'x_ascend_xmit_rate' => 'X-Ascend-Xmit-Rate', + 'usr_last_number_dialed_o' => 'USR-Last-Number-Dialed-Out', + 'acc_connect_rx_speed' => 'Acc-Connect-Rx-Speed', + 'acc_clearing_cause' => 'Acc-Clearing-Cause', + 'ascend_call_attempt_limi' => 'Ascend-Call-Attempt-Limit', + 'x_ascend_data_rate' => 'X-Ascend-Data-Rate', + 'termination_action' => 'Termination-Action', + 'ascend_pre_input_octets' => 'Ascend-Pre-Input-Octets', + 'x_ascend_ipx_route' => 'X-Ascend-IPX-Route', + 'x_ascend_ts_idle_mode' => 'X-Ascend-TS-Idle-Mode', + 'client_ip_address' => 'Client-IP-Address', + 'ascend_add_seconds' => 'Ascend-Add-Seconds', + 'login_ip_host' => 'Login-IP-Host', + 'annex_sw_version' => 'Annex-SW-Version', + 'huntgroup_name' => 'Huntgroup-Name', + 'usr_pw_vpn_gateway' => 'USR-PW_VPN_Gateway', + 'ascend_x25_reverse_charg' => 'Ascend-X25-Reverse-Charging', + 'lac_real_port' => 'LAC_Real_Port', + 'ascend_dba_monitor' => 'Ascend-DBA-Monitor', + 'annex_user_server_locati' => 'Annex-User-Server-Location', + 'ascend_h323_fegw_address' => 'Ascend-H323-Fegw-Address', + 'acct_output_gigawords' => 'Acct-Output-Gigawords', + 'bind_l2tp_tunnel_name' => 'Bind_L2TP_Tunnel_Name', + 'x_ascend_token_idle' => 'X-Ascend-Token-Idle', + 'acc_apsm_oversubscribed' => 'Acc-Apsm-Oversubscribed', + 'ip_tos_field' => 'IP_TOS_Field', + 'ascend_dsl_cir_xmit_limi' => 'Ascend-Dsl-CIR-Xmit-Limit', + 'usr_number_of_link_naks' => 'USR-Number-of-Link-NAKs', + 'framed_address' => 'Framed-Address', + 'x_ascend_num_in_multilin' => 'X-Ascend-Num-In-Multilink', + 'hint' => 'Hint', + 'ascend_source_ip_check' => 'Ascend-Source-IP-Check', + 'arap_zone_access' => 'ARAP-Zone-Access', + 'x_ascend_fr_direct_profi' => 'X-Ascend-FR-Direct-Profile', + 'x_ascend_bridge_address' => 'X-Ascend-Bridge-Address', + 'usr_iwf_call_identifier' => 'USR-IWF-Call-Identifier', + 'ascend_home_network_name' => 'Ascend-Home-Network-Name', + 'ascend_require_auth' => 'Ascend-Require-Auth', + 'source_validation' => 'Source_Validation', + 'ms_primary_nbns_server' => 'MS-Primary-NBNS-Server', + 'h323_setup_time' => 'h323-setup-time', + 'tunnel_remote_name' => 'Tunnel_Remote_Name', + 'ascend_maximum_channels' => 'Ascend-Maximum-Channels', + 'ascend_tunneling_protoco' => 'Ascend-Tunneling-Protocol', + 'arap_security_data' => 'ARAP-Security-Data', + 'ascend_ipx_peer_mode' => 'Ascend-IPX-Peer-Mode', + 'ascend_cir_timer' => 'Ascend-CIR-Timer', + 'ascend_ts_idle_limit' => 'Ascend-TS-Idle-Limit', + 'ascend_cache_refresh' => 'Ascend-Cache-Refresh', + 'usr_rmmie_status' => 'USR-RMMIE-Status', + 'annex_callback_portlist' => 'Annex-Callback-Portlist', + 'usr_port_tap' => 'USR-Port-Tap', + 'ascend_client_secondary_' => 'Ascend-Client-Secondary-DNS', + 'x_ascend_first_dest' => 'X-Ascend-First-Dest', + 'lac_port' => 'LAC_Port', + 'acc_callback_cbcp_type' => 'Acc-Callback-CBCP-Type', + 'usr_call_reference_numbe' => 'USR-Call-Reference-Number', + 'mcast_receive' => 'Mcast_Receive', + 'x_ascend_link_compressio' => 'X-Ascend-Link-Compression', + 'ascend_inter_arrival_jit' => 'Ascend-Inter-Arrival-Jitter', + 'x_ascend_assign_ip_pool' => 'X-Ascend-Assign-IP-Pool', + 'usr_chassis_call_span' => 'USR-Chassis-Call-Span', + 'arap_password' => 'ARAP-Password', + 'usr_ip_default_route_opt' => 'USR-IP-Default-Route-Option', + 'ascend_endpoint_disc' => 'Ascend-Endpoint-Disc', + 'tunnel_dnis' => 'Tunnel_DNIS', + 'ms_acct_auth_type' => 'MS-Acct-Auth-Type', + 'ascend_ts_idle_mode' => 'Ascend-TS-Idle-Mode', + 'shasta_service_profile' => 'Shasta-Service-Profile', + 'usr_cdma_call_reference_' => 'USR-CDMA-Call-Reference-Number', + 'usr_at_zip_input_filter' => 'USR-AT-Zip-Input-Filter', + 'x_ascend_pw_warntime' => 'X-Ascend-PW-Warntime', + 'ascend_fr_direct_dlci' => 'Ascend-FR-Direct-DLCI', + 'usr_dte_ring_no_answer_l' => 'USR-DTE-Ring-No-Answer-Limit', + 'ascend_multicast_rate_li' => 'Ascend-Multicast-Rate-Limit', + 'usr_routing_protocol' => 'USR-Routing-Protocol', + 'pam_auth' => 'Pam-Auth', + 'client_dns_sec' => 'Client_DNS_Sec', + 'bg_trans_bpdu' => 'BG_Trans_BPDU', + 'police_rate' => 'Police_Rate', + 'calling_station_id' => 'Calling-Station-Id', + 'usr_called_party_number' => 'USR-Called-Party-Number', + 'shiva_network_protocols' => 'Shiva-Network-Protocols', + 'x_ascend_client_gateway' => 'X-Ascend-Client-Gateway', + 'acct_input_octets' => 'Acct-Input-Octets', + 'ascend_call_type' => 'Ascend-Call-Type', + 'annex_product_name' => 'Annex-Product-Name', + 'framed_compression' => 'Framed-Compression', + 'ascend_atm_direct' => 'Ascend-ATM-Direct', + 'x_ascend_remote_addr' => 'X-Ascend-Remote-Addr', + 'usr_tunneled_mlpp' => 'USR-Tunneled-MLPP', + 'le_ipsec_outsource_profi' => 'LE-IPSec-Outsource-Profile', + 'ascend_atm_vci' => 'Ascend-ATM-Vci', + 'usr_number_of_link_timeo' => 'USR-Number-of-Link-Timeouts', + 'usr_et_bridge_input_filt' => 'USR-ET-Bridge-Input-Filter', + 'x_ascend_fr_t391' => 'X-Ascend-FR-T391', + 'x_ascend_fr_t392' => 'X-Ascend-FR-T392', + 'h323_conf_id' => 'h323-conf-id', + 'usr_call_end_date_time' => 'USR-Call-End-Date-Time', + 'ascend_fr_t391' => 'Ascend-FR-T391', + 'bg_aging_time' => 'BG_Aging_Time', + 'x_ascend_pre_output_pack' => 'X-Ascend-Pre-Output-Packets', + 'acc_dialout_auth_mode' => 'Acc-Dialout-Auth-Mode', + 'ascend_calling_subaddres' => 'Ascend-Calling-Subaddress', + 'ascend_fr_t392' => 'Ascend-FR-T392', + 'acct_link_count' => 'Acct-Link-Count', + 'usr_chassis_call_slot' => 'USR-Chassis-Call-Slot', + 'h323_credit_time' => 'h323-credit-time', + 'nas_port_id' => 'NAS-Port-Id', + 'x_ascend_call_filter' => 'X-Ascend-Call-Filter', + 'ascend_destination_nas_p' => 'Ascend-Destination-Nas-Port', + 'arap_features' => 'ARAP-Features', + 'x_ascend_history_weigh_t' => 'X-Ascend-History-Weigh-Type', + 'annex_host_restrict' => 'Annex-Host-Restrict', + 'usr_compression_reset_mo' => 'USR-Compression-Reset-Mode', + 'cisco_maximum_time' => 'Cisco-Maximum-Time', + 'tunnel_max_sessions' => 'Tunnel_Max_Sessions', + 'bind_ses_context' => 'Bind_Ses_Context', + 'x_ascend_ppp_vj_slot_com' => 'X-Ascend-PPP-VJ-Slot-Comp', + 'usr_mobile_numbytes_rxed' => 'USR-Mobile-NumBytes-Rxed', + 'usr_rmmie_last_update_ti' => 'USR-RMMIE-Last-Update-Time', + 'ascend_atm_loopback_cell' => 'Ascend-ATM-Loopback-Cell-Loss', + 'ascend_bir_proxy' => 'Ascend-BIR-Proxy', + 'acct_mcast_in_packets' => 'Acct_Mcast_In_Packets', + 'shiva_type_of_service' => 'Shiva-Type-Of-Service', + 'ascend_fr_dte_n392' => 'Ascend-FR-DTE-N392', + 'usr_at_call_input_filter' => 'USR-AT-Call-Input-Filter', + 'ascend_fr_dte_n393' => 'Ascend-FR-DTE-N393', + 'x_ascend_backup' => 'X-Ascend-Backup', + 'char_noecho' => 'Char-Noecho', + 'usr_rmmie_last_update_ev' => 'USR-RMMIE-Last-Update-Event', + 'le_advice_of_charge' => 'LE-Advice-of-Charge', + 'ascend_calling_id_type_o' => 'Ascend-Calling-Id-Type-Of-Num', + 'ascend_pppoe_enable' => 'Ascend-PPPoE-Enable', + 'usr_sync_async_mode' => 'USR-Sync-Async-Mode', + 'state' => 'State', + 'x_ascend_user_acct_base' => 'X-Ascend-User-Acct-Base', + 'x_ascend_ipx_alias' => 'X-Ascend-IPX-Alias', + 'ascend_ip_tos' => 'Ascend-IP-TOS', + 'annex_secondary_dns_serv' => 'Annex-Secondary-DNS-Server', + 'tunnel_session_auth_ctx' => 'Tunnel_Session_Auth_Ctx', + 'usr_mbi_ct_pri_card_span' => 'USR-Mbi_Ct_PRI_Card_Span_Line', + 'usr_call_event_code' => 'USR-Call-Event-Code', + 'chap_password' => 'CHAP-Password', + 'le_nat_tcp_session_timeo' => 'LE-NAT-TCP-Session-Timeout', + 'usr_call_start_date_time' => 'USR-Call-Start-Date-Time', + 'usr_multicast_forwarding' => 'USR-Multicast-Forwarding', + 'client_id' => 'Client-Id', + 'sql_user_name' => 'SQL-User-Name', + 'x_ascend_billing_number' => 'X-Ascend-Billing-Number', + 'ms_secondary_nbns_server' => 'MS-Secondary-NBNS-Server', + 'cisco_num_in_multilink' => 'Cisco-Num-In-Multilink', + 'x_ascend_client_assign_d' => 'X-Ascend-Client-Assign-DNS', + 'x_ascend_user_acct_port' => 'X-Ascend-User-Acct-Port', + 'usr_local_ip_address' => 'USR-Local-IP-Address', + 'x_ascend_ip_pool_definit' => 'X-Ascend-IP-Pool-Definition', + 'ascend_metric' => 'Ascend-Metric', + 'x_ascend_bacp_enable' => 'X-Ascend-BACP-Enable', + 'x_ascend_user_acct_time' => 'X-Ascend-User-Acct-Time', + 'x_ascend_mpp_idle_percen' => 'X-Ascend-MPP-Idle-Percent', + 'annex_authen_servers' => 'Annex-Authen-Servers', + 'x_ascend_data_filter' => 'X-Ascend-Data-Filter', + 'ascend_idle_limit' => 'Ascend-Idle-Limit', + 'ldap_userdn' => 'Ldap-UserDn', + 'x_ascend_target_util' => 'X-Ascend-Target-Util', + 'shiva_connect_reason' => 'Shiva-Connect-Reason', + 'usr_ds0' => 'USR-DS0', + 'annex_re_chap_timeout' => 'Annex-Re-CHAP-Timeout', + 'shasta_vpn_name' => 'Shasta-VPN-Name', + 'acct_tunnel_connection_i' => 'Acct-Tunnel-Connection-Id', + 'h323_prompt_id' => 'h323-prompt-id', + 'x_ascend_ipx_peer_mode' => 'X-Ascend-IPX-Peer-Mode', + 'ascend_numbering_plan_id' => 'Ascend-Numbering-Plan-ID', + 'x_ascend_ts_idle_limit' => 'X-Ascend-TS-Idle-Limit', + 'ascend_atm_fault_managem' => 'Ascend-ATM-Fault-Management', + 'annex_primary_nbns_serve' => 'Annex-Primary-NBNS-Server', + 'lac_port_type' => 'LAC_Port_Type', + 'usr_initial_rx_link_data' => 'USR-Initial-Rx-Link-Data-Rate', + 'usr_interface_index' => 'USR-Interface-Index', + 'usr_expansion_algorithm' => 'USR-Expansion-Algorithm', + 'ascend_tunnel_vrouter_na' => 'Ascend-Tunnel-VRouter-Name', + 'usr_pw_vpn_neighbor' => 'USR-PW_VPN_Neighbor', + 'bind_type' => 'Bind_Type', + 'acc_ccp_option' => 'Acc-Ccp-Option', + 'ascend_route_appletalk' => 'Ascend-Route-Appletalk', + 'erx_alternate_cli_access' => 'ERX-Alternate-Cli-Access-Level', + 'usr_at_rtmp_output_filte' => 'USR-AT-RTMP-Output-Filter', + 'erx_atm_mbs' => 'ERX-Atm-MBS', + 'usr_at_call_output_filte' => 'USR-AT-Call-Output-Filter', + 'ms_old_arap_password' => 'MS-Old-ARAP-Password', + 'x_ascend_client_primary_' => 'X-Ascend-Client-Primary-DNS', + 'x_ascend_host_info' => 'X-Ascend-Host-Info', + 'bind_auth_protocol' => 'Bind_Auth_Protocol', + 'cisco_link_compression' => 'Cisco-Link-Compression', + 'annex_syslog_tap' => 'Annex-Syslog-Tap', + 'tunnel_window' => 'Tunnel_Window', + 'usr_gateway_ip_address' => 'USR-Gateway-IP-Address', + 'ascend_redirect_number' => 'Ascend-Redirect-Number', + 'x_ascend_secondary_home_' => 'X-Ascend-Secondary-Home-Agent', + 'usr_pw_index' => 'USR-PW_Index', + 'le_multicast_client' => 'LE-Multicast-Client', + 'annex_modem_disc_reason' => 'Annex-Modem-Disc-Reason', + 'annex_primary_dns_server' => 'Annex-Primary-DNS-Server', + 'erx_secondary_wins' => 'ERX-Secondary-Wins', + 'fall_through' => 'Fall-Through', + 'acct_mcast_out_packets' => 'Acct_Mcast_Out_Packets', + 'x_ascend_transit_number' => 'X-Ascend-Transit-Number', + 'usr_unauthenticated_time' => 'USR-Unauthenticated-Time', + 'le_ipsec_active_profile' => 'LE-IPSec-Active-Profile', + 'ascend_ip_pool_chaining' => 'Ascend-IP-Pool-Chaining', + 'usr_syslog_tap' => 'USR-Syslog-Tap', + 'ascend_multicast_client' => 'Ascend-Multicast-Client', + 'usr_device_connected_to' => 'USR-Device-Connected-To', + 'tunnel_l2f_second_passwo' => 'Tunnel_L2F_Second_Password', + 'add_prefix' => 'Add-Prefix', + 'tunnel_cmd_timeout' => 'Tunnel_Cmd_Timeout', + 'x_ascend_remove_seconds' => 'X-Ascend-Remove-Seconds', + 'acct_mcast_in_octets' => 'Acct_Mcast_In_Octets', + 'ascend_appletalk_route' => 'Ascend-Appletalk-Route', + 'ascend_fcp_parameter' => 'Ascend-FCP-Parameter', + 'acc_ip_compression' => 'Acc-Ip-Compression', + 'usr_modem_training_time' => 'USR-Modem-Training-Time', + 'usr_primary_dns_server' => 'USR-Primary_DNS_Server', + 'erx_egress_policy_name' => 'ERX-Egress-Policy-Name', + 'x_ascend_base_channel_co' => 'X-Ascend-Base-Channel-Count', + 'x_ascend_pre_input_packe' => 'X-Ascend-Pre-Input-Packets', + 'password_retry' => 'Password-Retry', + 'ascend_source_auth' => 'Ascend-Source-Auth', + 'cisco_pw_lifetime' => 'Cisco-PW-Lifetime', + 'acc_dns_server_pri' => 'Acc-Dns-Server-Pri', + 'ascend_netware_timeout' => 'Ascend-Netware-timeout', + 'ascend_ppp_async_map' => 'Ascend-PPP-Async-Map', + 'usr_rad_multicast_routin' => 'USR-Rad-Multicast-Routing-Ttl', + 'x_ascend_modem_slotno' => 'X-Ascend-Modem-SlotNo', + 'x_ascend_ip_direct' => 'X-Ascend-IP-Direct', + 'simultaneous_use' => 'Simultaneous-Use', + 'erx_virtual_router_name' => 'ERX-Virtual-Router-Name', + 'ascend_bridge_non_pppoe' => 'Ascend-Bridge-Non-PPPoE', + 'ascend_fr_08_mode' => 'Ascend-FR-08-Mode', + 'h323_call_type' => 'h323-call-type', + 'tunnel_context' => 'Tunnel_Context', + 'usr_transmit_acc_map' => 'USR-Transmit-Acc-Map', + 'usr_ipx_wan' => 'USR-IPX-WAN', + 'usr_ip_call_input_filter' => 'USR-IP-Call-Input-Filter', + 'usr_call_connect_in_gmt' => 'USR-Call-Connect-in-GMT', + 'acct_multi_session_id' => 'Acct-Multi-Session-Id', + 'usr_reply_script1' => 'USR-Reply-Script1', + 'cisco_ppp_vj_slot_comp' => 'Cisco-PPP-VJ-Slot-Comp', + 'usr_reply_script2' => 'USR-Reply-Script2', + 'usr_reply_script3' => 'USR-Reply-Script3', + 'usr_reply_script4' => 'USR-Reply-Script4', + 'usr_reply_script5' => 'USR-Reply-Script5', + 'usr_reply_script6' => 'USR-Reply-Script6', + 'user_category' => 'User-Category', + 'mcast_send' => 'Mcast_Send', + 'ascend_send_secret' => 'Ascend-Send-Secret', + 'usr_tunnel_switch_endpoi' => 'USR-Tunnel-Switch-Endpoint', + 'tunnel_retransmit' => 'Tunnel_Retransmit', + 'add_port_to_ip_address' => 'Add-Port-To-IP-Address', + 'ascend_ipx_node_addr' => 'Ascend-IPX-Node-Addr', + 'x_ascend_netware_timeout' => 'X-Ascend-Netware-timeout', + 'erx_sa_validate' => 'ERX-Sa-Validate', + 'le_ipsec_passive_profile' => 'LE-IPSec-Passive-Profile', + 'usr_chassis_slot' => 'USR-Chassis-Slot', + 'usr_final_tx_link_data_r' => 'USR-Final-Tx-Link-Data-Rate', + 'usr_nfas_id' => 'USR-NFAS-ID', + 'called_station_id' => 'Called-Station-Id', + 'login_lat_port' => 'Login-LAT-Port', + 'ascend_dialed_number' => 'Ascend-Dialed-Number', + 'h323_credit_amount' => 'h323-credit-amount', + 'tunnel_local_name' => 'Tunnel_Local_Name', + 'framed_ip_netmask' => 'Framed-IP-Netmask', + 'client_port_id' => 'Client-Port-Id', + 'bg_span_dis' => 'BG_Span_Dis', + 'multi_link_flag' => 'Multi-Link-Flag', + 'bind_sub_user_at_context' => 'Bind_Sub_User_At_Context', + 'usr_ipx_routing' => 'USR-IPX-Routing', + 'ascend_fr_nailed_grp' => 'Ascend-FR-Nailed-Grp', + 'ascend_pre_output_octets' => 'Ascend-Pre-Output-Octets', + 'pppoe_url' => 'PPPOE_URL', + 'ascend_ara_pw' => 'Ascend-Ara-PW', + 'acc_callback_mode' => 'Acc-Callback-Mode', + 'usr_server_time' => 'USR-Server-Time', + 'ascend_seconds_of_histor' => 'Ascend-Seconds-Of-History', + 'ns_mta_md5_password' => 'NS-MTA-MD5-Password', + 'tunnel_server_endpoint' => 'Tunnel-Server-Endpoint', + 'usr_channel' => 'USR-Channel', + 'ascend_dsl_cir_recv_limi' => 'Ascend-Dsl-CIR-Recv-Limit', + 'acct_session_start_time' => 'Acct-Session-Start-Time', + 'ascend_send_passwd' => 'Ascend-Send-Passwd', + 'ascend_num_in_multilink' => 'Ascend-Num-In-Multilink', + 'usr_ip_rip_policies' => 'USR-IP-RIP-Policies', + 'vendor_specific' => 'Vendor-Specific', + 'x_ascend_event_type' => 'X-Ascend-Event-Type', + 'lac_real_port_type' => 'LAC_Real_Port_Type', + 'x_ascend_modem_portno' => 'X-Ascend-Modem-PortNo', + 'usr_originate_answer_mod' => 'USR-Originate-Answer-Mode', + 'framed_ipx_network' => 'Framed-IPX-Network', + 'ascend_modem_slotno' => 'Ascend-Modem-SlotNo', + 'ms_mppe_encryption_type' => 'MS-MPPE-Encryption-Type', + 'annex_cli_command' => 'Annex-CLI-Command', + 'acct_status_type' => 'Acct-Status-Type', + 'usr_et_bridge_call_outpu' => 'USR-ET-Bridge-Call-Output-Filte', + 'usr_pw_vpn_id' => 'USR-PW_VPN_ID', + 'usr_sap_filter_in' => 'USR-SAP-Filter-In', + 'usr_rad_multicast_routin' => 'USR-Rad-Multicast-Routing-Proto', + 'annex_audit_level' => 'Annex-Audit-Level', + 'x_ascend_shared_profile_' => 'X-Ascend-Shared-Profile-Enable', + 'ascend_dial_number' => 'Ascend-Dial-Number', + 'ascend_link_compression' => 'Ascend-Link-Compression', + 'usr_event_date_time' => 'USR-Event-Date-Time', + 'usr_mp_edo_hiper' => 'USR-MP-EDO-HIPER', + 'usr_re_chap_timeout' => 'USR-Re-Chap-Timeout', + 'x_ascend_third_prompt' => 'X-Ascend-Third-Prompt', + 'x_ascend_ppp_vj_1172' => 'X-Ascend-PPP-VJ-1172', + 'annex_disconnect_reason' => 'Annex-Disconnect-Reason', + 'ascend_fr_svc_addr' => 'Ascend-FR-SVC-Addr', + 'nas_real_port' => 'NAS_Real_Port', + 'usr_power_supply_number' => 'USR-Power-Supply-Number', + 'ms_secondary_dns_server' => 'MS-Secondary-DNS-Server', + 'ascend_port_redir_server' => 'Ascend-Port-Redir-Server', + 'ascend_x25_pad_alias_1' => 'Ascend-X25-Pad-Alias-1', + 'x_ascend_fcp_parameter' => 'X-Ascend-FCP-Parameter', + 'ascend_x25_pad_alias_2' => 'Ascend-X25-Pad-Alias-2', + 'ascend_ipsec_profile' => 'Ascend-IPSEC-Profile', + 'ascend_x25_pad_alias_3' => 'Ascend-X25-Pad-Alias-3', + 'usr_mobile_numbytes_txed' => 'USR-Mobile-NumBytes-Txed', + 'ascend_atm_vpi' => 'Ascend-ATM-Vpi', + 'annex_input_filter' => 'Annex-Input-Filter', + 'menu' => 'Menu', + 'x_ascend_route_ip' => 'X-Ascend-Route-IP', + 'usr_rmmie_num_of_updates' => 'USR-RMMIE-Num-Of-Updates', + 'acc_request_type' => 'Acc-Request-Type', + 'ascend_dhcp_reply' => 'Ascend-DHCP-Reply', + 'usr_number_of_upshifts' => 'USR-Number-of-Upshifts', + 'usr_rmmie_firmware_versi' => 'USR-RMMIE-Firmware-Version', + 'bind_bypass_context' => 'Bind_Bypass_Context', + 'ascend_dialout_allowed' => 'Ascend-Dialout-Allowed', + 'annex_tunnel_authen_type' => 'Annex-Tunnel-Authen-Type', + 'x_ascend_bridge' => 'X-Ascend-Bridge', + 'ascend_client_secondary_' => 'Ascend-Client-Secondary-WINS', + 'erx_local_loopback_inter' => 'ERX-Local-Loopback-Interface', + 'acct_input_gigawords' => 'Acct-Input-Gigawords', + 'usr_equalization_type' => 'USR-Equalization-Type', + 'usr_port_tap_format' => 'USR-Port-Tap-Format', + 'x_ascend_ppp_async_map' => 'X-Ascend-PPP-Async-Map', + 'acc_ipx_compression' => 'Acc-Ipx-Compression', + 'ascend_nas_port_format' => 'Ascend-NAS-Port-Format', + 'acc_modem_modulation_typ' => 'Acc-Modem-Modulation-Type', + 'ascend_modem_portno' => 'Ascend-Modem-PortNo', + 'usr_et_bridge_output_fil' => 'USR-ET-Bridge-Output-Filter', + 'ascend_ipx_header_compre' => 'Ascend-IPX-Header-Compression', + 'framed_appletalk_link' => 'Framed-AppleTalk-Link', + 'x_ascend_receive_secret' => 'X-Ascend-Receive-Secret', + 'ascend_route_ipx' => 'Ascend-Route-IPX', + 'ascend_user_acct_type' => 'Ascend-User-Acct-Type', + 'ascend_token_idle' => 'Ascend-Token-Idle', + 'framed_ip_address' => 'Framed-IP-Address', + 'ascend_call_block_durati' => 'Ascend-Call-Block-Duration', + 'ascend_ppp_address' => 'Ascend-PPP-Address', + 'usr_mbi_ct_pri_card_slot' => 'USR-Mbi_Ct_PRI_Card_Slot', + 'x_ascend_dec_channel_cou' => 'X-Ascend-Dec-Channel-Count', + 'x_ascend_send_auth' => 'X-Ascend-Send-Auth', + 'usr_characters_received' => 'USR-Characters-Received', + 'usr_pw_tunnel_authentica' => 'USR-PW_Tunnel_Authentication', + 'usr_call_end_time' => 'USR-Call-End-Time', + 'x_ascend_dialout_allowed' => 'X-Ascend-Dialout-Allowed', + 'x_ascend_call_attempt_li' => 'X-Ascend-Call-Attempt-Limit', + 'initial_modulation_type' => 'Initial-Modulation-Type', + 'usr_packet_bus_session' => 'USR-Packet-Bus-Session', + 'x_ascend_ipx_node_addr' => 'X-Ascend-IPX-Node-Addr', + 'ascend_ppp_vj_slot_comp' => 'Ascend-PPP-VJ-Slot-Comp', + 'ascend_menu_item' => 'Ascend-Menu-Item', + 'x_ascend_fr_link_mgt' => 'X-Ascend-FR-Link-Mgt', + 'usr_rmmie_serial_number' => 'USR-RMMIE-Serial-Number', + 'message_authenticator' => 'Message-Authenticator', + 'usr_dte_data_idle_timout' => 'USR-DTE-Data-Idle-Timout', + 'usr_port_tap_facility' => 'USR-Port-Tap-Facility', + 'acc_ml_mlx_admin_state' => 'Acc-ML-MLX-Admin-State', + 'usr_modem_group' => 'USR-Modem-Group', + 'x_ascend_callback' => 'X-Ascend-Callback', + 'acct_input_packets_64' => 'Acct_Input_Packets_64', + 'ascend_third_prompt' => 'Ascend-Third-Prompt', + 'configuration_token' => 'Configuration-Token', + 'x_ascend_fr_nailed_grp' => 'X-Ascend-FR-Nailed-Grp', + 'acct_output_octets_64' => 'Acct_Output_Octets_64', + 'h323_time_and_day' => 'h323-time-and-day', + 'ascend_port_redir_portnu' => 'Ascend-Port-Redir-Portnum', + 'acct_interim_interval' => 'Acct-Interim-Interval', + 'ascend_uu_info' => 'Ascend-UU-Info', + 'usr_pw_vpn_name' => 'USR-PW_VPN_Name', + 'ascend_maximum_call_dura' => 'Ascend-Maximum-Call-Duration', + 'ascend_atm_direct_profil' => 'Ascend-ATM-Direct-Profile', + 'acc_input_errors' => 'Acc-Input-Errors', + 'bind_dot1q_port' => 'Bind_Dot1q_Port', + 'ascend_first_dest' => 'Ascend-First-Dest', + 'x_ascend_if_netmask' => 'X-Ascend-IF-Netmask', + 'tunnel_session_auth_serv' => 'Tunnel_Session_Auth_Service_Grp', + 'annex_local_ip_address' => 'Annex-Local-IP-Address', + 'termination_menu' => 'Termination-Menu', + 'ms_chap2_cpw' => 'MS-CHAP2-CPW', + 'ascend_mpp_idle_percent' => 'Ascend-MPP-Idle-Percent', + 'usr_characters_sent' => 'USR-Characters-Sent', + 'eap_message' => 'EAP-Message', + 'acct_delay_time' => 'Acct-Delay-Time', + 'ascend_remote_fw' => 'Ascend-Remote-FW', + 'x_ascend_tunneling_proto' => 'X-Ascend-Tunneling-Protocol', + 'shiva_session_id' => 'Shiva-Session-Id', + 'usr_igmp_query_interval' => 'USR-IGMP-Query-Interval', + 'usr_accm_type' => 'USR-ACCM-Type', + 'usr_call_terminate_in_gm' => 'USR-Call-Terminate-in-GMT', + 'usr_rad_location_type' => 'USR-Rad-Location-Type', + 'ascend_filter' => 'Ascend-Filter', + 'ascend_primary_home_agen' => 'Ascend-Primary-Home-Agent', + 'x_ascend_user_acct_host' => 'X-Ascend-User-Acct-Host', + 'chap_challenge' => 'CHAP-Challenge', + 'acct_output_packets_64' => 'Acct_Output_Packets_64', + 'bind_auth_max_sessions' => 'Bind_Auth_Max_Sessions', + 'cisco_pre_output_octets' => 'Cisco-Pre-Output-Octets', + 'x_ascend_fr_direct' => 'X-Ascend-FR-Direct', + 'x_ascend_client_secondar' => 'X-Ascend-Client-Secondary-DNS', + 'usr_rmmie_pwrlvl_nearech' => 'USR-RMMIE-PwrLvl-NearEcho-Canc', + 'ascend_bridge_address' => 'Ascend-Bridge-Address', + 'user_name' => 'User-Name', + 'usr_rmmie_firmware_build' => 'USR-RMMIE-Firmware-Build-Date', + 'ms_chap_mppe_keys' => 'MS-CHAP-MPPE-Keys', + 'usr_number_of_characters' => 'USR-Number-Of-Characters-Lost', + 'usr_physical_state' => 'USR-Physical-State', + 'x_ascend_assign_ip_serve' => 'X-Ascend-Assign-IP-Server', + 'bind_int_context' => 'Bind_Int_Context', + 'erx_tunnel_virtual_route' => 'ERX-Tunnel-Virtual-Router', + 'ascend_xmit_rate' => 'Ascend-Xmit-Rate', + 'usr_secondary_dns_server' => 'USR-Secondary_DNS_Server', + 'ascend_dsl_rate_mode' => 'Ascend-Dsl-Rate-Mode', + 'ascend_data_rate' => 'Ascend-Data-Rate', + 'realm' => 'Realm', + 'usr_ipx_call_input_filte' => 'USR-IPX-Call-Input-Filter', + 'ascend_ipx_route' => 'Ascend-IPX-Route', + 'usr_failure_to_connect_r' => 'USR-Failure-to-Connect-Reason', + 'x_ascend_home_network_na' => 'X-Ascend-Home-Network-Name', + 'acc_nbns_server_pri' => 'Acc-Nbns-Server-Pri', + 'usr_modulation_type' => 'USR-Modulation-Type', + 'service_type' => 'Service-Type', + 'ascend_callback_delay' => 'Ascend-Callback-Delay', + 'ascend_owner_ip_addr' => 'Ascend-Owner-IP-Addr', + 'x_ascend_handle_ipx' => 'X-Ascend-Handle-IPX', + 'usr_connect_term_reason' => 'USR-Connect-Term-Reason', + 'x_ascend_multicast_rate_' => 'X-Ascend-Multicast-Rate-Limit', + 'h323_disconnect_time' => 'h323-disconnect-time', + 'acc_ip_gateway_sec' => 'Acc-Ip-Gateway-Sec', + 'usr_number_of_blers' => 'USR-Number-of-Blers', + 'x_ascend_fr_type' => 'X-Ascend-FR-Type', + 'ascend_assign_ip_pool' => 'Ascend-Assign-IP-Pool', + 'ascend_qos_upstream' => 'Ascend-QOS-Upstream', + 'usr_nas_type' => 'USR-NAS-Type', + 'acc_dial_port_index' => 'Acc-Dial-Port-Index', + 'usr_initial_tx_link_data' => 'USR-Initial-Tx-Link-Data-Rate', + 'ascend_fr_type' => 'Ascend-FR-Type', + 'usr_mbi_ct_tdm_time_slot' => 'USR-Mbi_Ct_TDM_Time_Slot', + 'usr_rmmie_pwrlvl_xmit_lv' => 'USR-RMMIE-PwrLvl-Xmit-Lvl', + 'erx_atm_service_category' => 'ERX-Atm-Service-Category', + 'usr_appletalk' => 'USR-Appletalk', + 'usr_send_script1' => 'USR-Send-Script1', + 'usr_send_script2' => 'USR-Send-Script2', + 'usr_send_script3' => 'USR-Send-Script3', + 'usr_ospf_addressless_ind' => 'USR-OSPF-Addressless-Index', + 'acct_input_packets' => 'Acct-Input-Packets', + 'usr_send_script4' => 'USR-Send-Script4', + 'usr_send_script5' => 'USR-Send-Script5', + 'usr_send_script6' => 'USR-Send-Script6', + 'usr_service_option' => 'USR-Service-Option', + 'ascend_dropped_octets' => 'Ascend-Dropped-Octets', + 'usr_ip' => 'USR-IP', + 'usr_tunnel_security' => 'USR-Tunnel-Security', + 'acc_acct_on_off_reason' => 'Acc-Acct-On-Off-Reason', + 'shiva_compression_type' => 'Shiva-Compression-Type', + 'ascend_pw_warntime' => 'Ascend-PW-Warntime', + 'usr_security_resp_limit' => 'USR-Security-Resp-Limit', + 'ascend_x25_pad_prompt' => 'Ascend-X25-Pad-Prompt', + 'cisco_asing_ip_pool' => 'Cisco-Asing-IP-Pool', + 'acc_route_policy' => 'Acc-Route-Policy', + 'annex_local_username' => 'Annex-Local-Username', + 'x_ascend_call_by_call' => 'X-Ascend-Call-By-Call', + 'ascend_calling_id_screen' => 'Ascend-Calling-Id-Screening', + 'x_ascend_dhcp_pool_numbe' => 'X-Ascend-DHCP-Pool-Number', + 'nas_port_type' => 'NAS-Port-Type', + 'ascend_route_ip' => 'Ascend-Route-IP', + 'ascend_client_gateway' => 'Ascend-Client-Gateway', + 'ascend_qos_downstream' => 'Ascend-QOS-Downstream', + 'ms_bap_usage' => 'MS-BAP-Usage', + 'usr_vts_session_key' => 'USR-VTS-Session-Key', + 'usr_receive_acc_map' => 'USR-Receive-Acc-Map', + 'ascend_expect_callback' => 'Ascend-Expect-Callback', + 'password' => 'Password', + 'packet_type' => 'Packet-Type', + 'ascend_remote_addr' => 'Ascend-Remote-Addr', + 'ascend_recv_name' => 'Ascend-Recv-Name', + 'ms_acct_eap_type' => 'MS-Acct-EAP-Type', + 'usr_filter_zones' => 'USR-Filter-Zones', + 'annex_output_filter' => 'Annex-Output-Filter', + 'usr_rmmie_rcv_tot_pwrlvl' => 'USR-RMMIE-Rcv-Tot-PwrLvl', + 'usr_mp_mrru' => 'USR-MP-MRRU', + 'ascend_call_filter' => 'Ascend-Call-Filter', + 'usr_keypress_timeout' => 'USR-Keypress-Timeout', + 'usr_modem_setup_time' => 'USR-Modem-Setup-Time', + 'acct_authentic' => 'Acct-Authentic', + 'pppoe_motm' => 'PPPOE_MOTM', + 'x_ascend_expect_callback' => 'X-Ascend-Expect-Callback', + 'erx_atm_scr' => 'ERX-Atm-SCR', + 'erx_address_pool_name' => 'ERX-Address-Pool-Name', + 'challenge_state' => 'Challenge-State', + 'usr_multicast_proxy' => 'USR-Multicast-Proxy', + 'framed_filter_id' => 'Framed-Filter-Id', + 'add_suffix' => 'Add-Suffix', + 'ascend_auth_type' => 'Ascend-Auth-Type', + 'session_timeout' => 'Session-Timeout', + 'ascend_callback' => 'Ascend-Callback', + 'usr_chat_script_name' => 'USR-Chat-Script-Name', + 'port_message' => 'Port-Message', + 'acct_output_packets' => 'Acct-Output-Packets', + 'ascend_session_svr_key' => 'Ascend-Session-Svr-Key', + 'login_tcp_port' => 'Login-TCP-Port', + 'erx_tunnel_password' => 'ERX-Tunnel-Password', + 'shasta_user_privilege' => 'Shasta-User-Privilege', + 'usr_secondary_nbns_serve' => 'USR-Secondary_NBNS_Server', + 'usr_security_login_limit' => 'USR-Security-Login-Limit', + 'usr_start_time' => 'USR-Start-Time', + 'acc_access_partition' => 'Acc-Access-Partition', + 'versanet_termination_cau' => 'Versanet-Termination-Cause', + 'x_ascend_call_block_dura' => 'X-Ascend-Call-Block-Duration', + 'mcast_maxgroups' => 'Mcast_MaxGroups', + 'ascend_user_acct_base' => 'Ascend-User-Acct-Base', + 'usr_vpn_gw_location_id' => 'USR-VPN-GW-Location-Id', + 'usr_block_error_count_li' => 'USR-Block-Error-Count-Limit', + 'ascend_telnet_profile' => 'Ascend-Telnet-Profile', + 'ascend_port_redir_protoc' => 'Ascend-Port-Redir-Protocol', + 'ascend_call_by_call' => 'Ascend-Call-By-Call', + 'usr_disconnect_cause_ind' => 'USR-Disconnect-Cause-Indicator', + 'x_ascend_fr_linkup' => 'X-Ascend-FR-LinkUp', + 'ascend_billing_number' => 'Ascend-Billing-Number', + 'usr_ds0s' => 'USR-DS0s', + 'usr_at_zip_output_filter' => 'USR-AT-Zip-Output-Filter', + 'ascend_user_acct_port' => 'Ascend-User-Acct-Port', + 'login_port' => 'Login-Port', + 'arap_security' => 'ARAP-Security', + 'tunnel_deadtime' => 'Tunnel_Deadtime', + 'ascend_user_acct_time' => 'Ascend-User-Acct-Time', + 'ms_chap_challenge' => 'MS-CHAP-Challenge', + 'ascend_x25_rpoa' => 'Ascend-X25-Rpoa', + 'login_time' => 'Login-Time', + 'current_time' => 'Current-Time', + 'login_service' => 'Login-Service', + 'ascend_menu_selector' => 'Ascend-Menu-Selector', + 'ascend_bacp_enable' => 'Ascend-BACP-Enable', + 'shiva_link_speed' => 'Shiva-Link-Speed', + 'ascend_private_route_tab' => 'Ascend-Private-Route-Table-ID', + 'x_ascend_session_svr_key' => 'X-Ascend-Session-Svr-Key', + 'ascend_data_filter' => 'Ascend-Data-Filter', + 'ascend_target_util' => 'Ascend-Target-Util', + 'shiva_function' => 'Shiva-Function', + 'usr_pw_usr_ifilter_ip' => 'USR-PW_USR_IFilter_IP', + 'usr_igmp_routing' => 'USR-IGMP-Routing', + 'acc_tunnel_port' => 'Acc-Tunnel-Port', + 'x_ascend_fr_n391' => 'X-Ascend-FR-N391', + 'medium_type' => 'Medium_Type', + 'annex_domain_name' => 'Annex-Domain-Name', + 'ascend_fr_n391' => 'Ascend-FR-N391', + 'callback_number' => 'Callback-Number', + 'usr_chassis_temperature' => 'USR-Chassis-Temperature', + 'dialback_no' => 'Dialback-No', + 'ms_mppe_recv_key' => 'MS-MPPE-Recv-Key', + 'ascend_ipx_alias' => 'Ascend-IPX-Alias', + 'le_nat_inmap' => 'LE-NAT-Inmap', + 'tunnel_police_rate' => 'Tunnel_Police_Rate', + 'acct_terminate_cause' => 'Acct-Terminate-Cause', + 'le_nat_other_session_tim' => 'LE-NAT-Other-Session-Timeout', + 'usr_ip_rip_output_filter' => 'USR-IP-RIP-Output-Filter', + 'exec_program' => 'Exec-Program', + 'h323_disconnect_cause' => 'h323-disconnect-cause', + 'usr_chassis_call_channel' => 'USR-Chassis-Call-Channel', + 'x_ascend_fr_dlci' => 'X-Ascend-FR-DLCI', + 'ms_link_drop_time_limit' => 'MS-Link-Drop-Time-Limit', + 'acc_callback_num_valid' => 'Acc-Callback-Num-Valid', + 'cisco_presession_time' => 'Cisco-PreSession-Time', + 'ms_chap_response' => 'MS-CHAP-Response', + 'usr_spoofing' => 'USR-Spoofing', + 'usr_num_fax_pages_proces' => 'USR-Num-Fax-Pages-Processed', + 'ascend_x25_cug' => 'Ascend-X25-Cug', + 'ascend_fr_dlci' => 'Ascend-FR-DLCI', + 'shiva_user_attributes' => 'Shiva-User-Attributes', + 'ms_chap_lm_enc_pw' => 'MS-CHAP-LM-Enc-PW', + 'ascend_transit_number' => 'Ascend-Transit-Number', + 'usr_last_number_dialed_i' => 'USR-Last-Number-Dialed-In-DNIS', + 'usr_ip_saa_filter' => 'USR-IP-SAA-Filter', + 'usr_pw_usr_ifilter_ipx' => 'USR-PW_USR_IFilter_IPX', + 'ascend_remove_seconds' => 'Ascend-Remove-Seconds', + 'le_connect_detail' => 'LE-Connect-Detail', + 'ascend_assign_ip_global_' => 'Ascend-Assign-IP-Global-Pool', + 'proxy_to_realm' => 'Proxy-To-Realm', + 'usr_retrains_requested' => 'USR-Retrains-Requested', + 'h323_remote_address' => 'h323-remote-address', + 'ascend_x25_nui_prompt' => 'Ascend-X25-Nui-Prompt', + 'acc_customer_id' => 'Acc-Customer-Id', + 'ms_chap2_response' => 'MS-CHAP2-Response', + 'ascend_host_info' => 'Ascend-Host-Info', + 'annex_addr_resolution_se' => 'Annex-Addr-Resolution-Servers', + 'x_ascend_multilink_id' => 'X-Ascend-Multilink-ID', + 'login_lat_service' => 'Login-LAT-Service', + 'usr_rmmie_rcv_pwrlvl_330' => 'USR-RMMIE-Rcv-PwrLvl-3300Hz', + 'ascend_event_type' => 'Ascend-Event-Type', + 'ascend_inc_channel_count' => 'Ascend-Inc-Channel-Count', + 'cisco_ppp_async_map' => 'Cisco-PPP-Async-Map', + 'usr_min_compression_size' => 'USR-Min-Compression-Size', + 'ascend_traffic_shaper' => 'Ascend-Traffic-Shaper', + 'ascend_user_acct_key' => 'Ascend-User-Acct-Key', + 'usr_port_tap_output' => 'USR-Port-Tap-Output', + 'ascend_x25_nui' => 'Ascend-X25-Nui', + 'x_ascend_disconnect_caus' => 'X-Ascend-Disconnect-Cause', + 'ascend_cbcp_enable' => 'Ascend-CBCP-Enable', + 'usr_framed_ip_address_po' => 'USR-Framed_IP_Address_Pool_Name', + 'ascend_x25_profile_name' => 'Ascend-X25-Profile-Name', + 'usr_orig_nas_type' => 'USR-Orig-NAS-Type', + 'acc_output_errors' => 'Acc-Output-Errors', + 'h323_redirect_ip_address' => 'h323-redirect-ip-address', + 'usr_ip_call_output_filte' => 'USR-IP-Call-Output-Filter', + 'cisco_avpair' => 'Cisco-AVPair', + 'usr_slot_connected_to' => 'USR-Slot-Connected-To', + 'framed_route' => 'Framed-Route', + 'ascend_global_call_id' => 'Ascend-Global-Call-Id', + 'x_ascend_seconds_of_hist' => 'X-Ascend-Seconds-Of-History', + 'x_ascend_temporary_rtes' => 'X-Ascend-Temporary-Rtes', + 'h323_currency_type' => 'h323-currency-type', + 'x_ascend_token_expiry' => 'X-Ascend-Token-Expiry', + 'pvc_encapsulation_type' => 'PVC_Encapsulation_Type', + 'x_ascend_pw_lifetime' => 'X-Ascend-PW-Lifetime', + 'usr_expected_voltage' => 'USR-Expected-Voltage', + 'usr_simplified_v42bis_us' => 'USR-Simplified-V42bis-Usage', + 'shiva_customer_id' => 'Shiva-Customer-Id', + 'usr_compression_algorith' => 'USR-Compression-Algorithm', + 'annex_system_disc_reason' => 'Annex-System-Disc-Reason', + 'annex_secondary_nbns_ser' => 'Annex-Secondary-NBNS-Server', + 'usr_q931_call_reference_' => 'USR-Q931-Call-Reference-Value', + 'usr_send_password' => 'USR-Send-Password', + 'prompt' => 'Prompt', + 'usr_cusr_hat_script_rule' => 'USR-CUSR-hat-Script-Rules', + 'usr_event_id' => 'USR-Event-Id', + 'usr_ccp_algorithm' => 'USR-CCP-Algorithm', + 'usr_mbi_ct_bchannel_used' => 'USR-Mbi_Ct_BChannel_Used', + 'ascend_svc_enabled' => 'Ascend-SVC-Enabled', + 'framed_mtu' => 'Framed-MTU', + 'acc_reason_code' => 'Acc-Reason-Code', + 'bind_l2tp_flow_control' => 'Bind_L2TP_Flow_Control', + 'ascend_cbcp_delay' => 'Ascend-CBCP-Delay', + 'le_ipsec_deny_action' => 'LE-IPSec-Deny-Action', +); + +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..042c243fd --- /dev/null +++ b/FS/FS/svc_Common.pm @@ -0,0 +1,224 @@ +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 = $self->cust_svc; + $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 = $self->cust_svc; + 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 + my $table = $self->table; + foreach my $field ( grep { $_ ne 'svcnum' } fields($table) ) { + my $part_svc_column = $part_svc->part_svc_column($field); + if ( $part_svc_column->columnflag eq $x ) { + $self->setfield( $field, $part_svc_column->columnvalue ); + } + } + + $part_svc; + +} + +=item cust_svc + +Returns the cust_svc record associated with this svc_ record, as a FS::cust_svc +object (see L<FS::cust_svc>). + +=cut + +sub cust_svc { + my $self = shift; + qsearchs('cust_svc', { 'svcnum' => $self->svcnum } ); +} + +=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.7 2001-11-30 00:04:38 ivan Exp $ + +=head1 BUGS + +The setfixed method return value. + +=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..b90cbe8d3 --- /dev/null +++ b/FS/FS/svc_acct.pm @@ -0,0 +1,1232 @@ +package FS::svc_acct; + +use strict; +use vars qw( @ISA $nossh_hack $conf $dir_prefix @shells $usernamemin + $usernamemax $passwordmin $passwordmax + $username_ampersand $username_letter $username_letterfirst + $username_noperiod $username_uppercase + $shellmachine $useradd $usermod $userdel $mydomain + $cyrus_server $cyrus_admin_user $cyrus_admin_pass + $cp_server $cp_user $cp_pass $cp_workgroup + $dirhash + $icradius_dbh + @saltset @pw_set); +use Carp; +use FS::Conf; +use FS::Record qw( qsearch qsearchs fields dbh ); +use FS::svc_Common; +use Net::SSH; +use FS::part_svc; +use FS::svc_acct_pop; +use FS::svc_acct_sm; +use FS::cust_main_invoice; +use FS::svc_domain; +use FS::raddb; +use FS::queue; + +@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; + $passwordmax = $conf->config('passwordmax') || 8; + 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'. + ')'; + } + $username_letter = $conf->exists('username-letter'); + $username_letterfirst = $conf->exists('username-letterfirst'); + $username_noperiod = $conf->exists('username-noperiod'); + $username_uppercase = $conf->exists('username-uppercase'); + $username_ampersand = $conf->exists('username-ampersand'); + $mydomain = $conf->config('domain'); + if ( $conf->exists('cyrus') ) { + ($cyrus_server, $cyrus_admin_user, $cyrus_admin_pass) = + $conf->config('cyrus'); + eval "use Cyrus::IMAP::Admin;" + } else { + $cyrus_server = ''; + $cyrus_admin_user = ''; + $cyrus_admin_pass = ''; + } + if ( $conf->exists('cp_app') ) { + ($cp_server, $cp_user, $cp_pass, $cp_workgroup) = + $conf->config('cp_app'); + eval "use Net::APP;" + } else { + $cp_server = ''; + $cp_user = ''; + $cp_pass = ''; + $cp_workgroup = ''; + } + if ( $conf->exists('icradiusmachines') ) { + if ( $conf->exists('icradius_secrets') ) { + #need some sort of late binding so it's only connected to when + # actually used, hmm + $icradius_dbh = DBI->connect($conf->config('icradius_secrets')) + or die $DBI::errstr; + } else { + $icradius_dbh = dbh; + } + } else { + $icradius_dbh = ''; + } + $dirhash = $conf->config('dirhash') || 0; +}; + +@saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' ); +@pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' ); + +#not needed in 5.004 #srand($$|time); + +sub _cache { + my $self = shift; + my ( $hashref, $cache ) = @_; + if ( $hashref->{'svc_acct_svcnum'} ) { + $self->{'_domsvc'} = FS::svc_domain->new( { + 'svcnum' => $hashref->{'domsvc'}, + 'domain' => $hashref->{'svc_acct_domain'}, + 'catchall' => $hashref->{'svc_acct_catchall'}, + } ); + } +} + +=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; + + %hash = $record->radius_reply; + + %hash = $record->radius_check; + + $domain = $record->domain; + + $svc_domain = $record->svc_domain; + + $email = $record->email; + + $seconds_since = $record->seconds_since($timestamp); + +=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 seconds - + +=item domsvc - svcnum from svc_domain + +=item radius_I<Radius_Attribute> - I<Radius-Attribute> + +=item domsvc - service number of svc_domain with which to associate + +=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 added to the job queue (see +L<FS::queue> and L<freeside-queued>) to be 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. + +(TODOC: cyrus config file, L<FS::queue> and L<freeside-queued>) + +=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; + + my $amount = 0; + + $error = $self->check; + return $error if $error; + + return "Username ". $self->username. " in use" + if qsearchs( 'svc_acct', { 'username' => $self->username, + 'domsvc' => $self->domsvc, + } ); + + my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } ); + return "Unknown svcpart" unless $part_svc; + return "uid in use" + if $part_svc->part_svc_column('uid')->columnflag ne 'F' + && qsearchs( 'svc_acct', { 'uid' => $self->uid } ) + && $self->username !~ /^(hyla)?fax$/ + ; + + $error = $self->SUPER::insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + my( $username, $uid, $gid, $dir, $shell ) = ( + $self->username, + $self->uid, + $self->gid, + $self->dir, + $self->shell, + ); + if ( $username && $uid && $dir && $shellmachine && ! $nossh_hack ) { + my $queue = new FS::queue { + 'svcnum' => $self->svcnum, + 'job' => 'Net::SSH::ssh_cmd', + }; + $error = $queue->insert("root\@$shellmachine", eval qq("$useradd") ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + } + + if ( $cyrus_server ) { + my $queue = new FS::queue { + 'svcnum' => $self->svcnum, + 'job' => 'FS::svc_acct::cyrus_insert', + }; + $error = $queue->insert($self->username, $self->quota); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + } + + if ( $cp_server ) { + my $queue = new FS::queue { + 'svcnum' => $self->svcnum, + 'job' => 'FS::svc_acct::cp_insert' + }; + $error = $queue->insert($self->username, $self->_password); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + } + + if ( $icradius_dbh ) { + + my $radcheck_queue = + new FS::queue { + 'svcnum' => $self->svcnum, + 'job' => 'FS::svc_acct::icradius_rc_insert' + }; + $error = $radcheck_queue->insert( $self->username, + $self->_password, + $self->radius_check + ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + + my $radreply_queue = + new FS::queue { + 'svcnum' => $self->svcnum, + 'job' => 'FS::svc_acct::icradius_rr_insert' + }; + $error = $radreply_queue->insert( $self->username, + $self->_password, + $self->radius_reply + ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; #no error +} + +sub cyrus_insert { + my( $username, $quota ) = @_; + + warn "cyrus_insert: starting for user $username, quota $quota\n"; + + warn "cyrus_insert: connecting to $cyrus_server\n"; + my $client = Cyrus::IMAP::Admin->new($cyrus_server); + + warn "cyrus_insert: authentication as $cyrus_admin_user\n"; + $client->authenticate( + -user => $cyrus_admin_user, + -mechanism => "login", + -password => $cyrus_admin_pass + ); + + warn "cyrus_insert: creating user.$username\n"; + my $rc = $client->create("user.$username"); + my $error = $client->error; + die "cyrus_insert: error creating user.$username: $error" if $error; + + warn "cyrus_insert: setacl user.$username, $username => all\n"; + $rc = $client->setacl("user.$username", $username => 'all' ); + $error = $client->error; + die "cyrus_insert: error setacl user.$username: $error" if $error; + + if ( $quota ) { + warn "cyrus_insert: setquota user.$username, STORAGE => $quota\n"; + $rc = $client->setquota("user.$username", 'STORAGE' => $quota ); + $error = $client->error; + die "cyrus_insert: error setquota user.$username: $error" if $error; + } + + 1; +} + +sub cp_insert { + my( $username, $password ) = @_; + + my $app = new Net::APP ( $cp_server, + User => $cp_user, + Password => $cp_pass, + Domain => $mydomain, + Timeout => 60, + #Debug => 1, + ) or die "$@\n"; + + $app->create_mailbox( + Mailbox => $username, + Password => $password, + Workgroup => $cp_workgroup, + Domain => $mydomain, + ); + + die $app->message."\n" unless $app->ok; +} + +sub icradius_rc_insert { + my( $username, $password, %radcheck ) = @_; + + my $sth = $icradius_dbh->prepare( + "INSERT INTO radcheck ( id, UserName, Attribute, Value ) VALUES ( ". + join(", ", map { $icradius_dbh->quote($_) } ( + '', + $username, + "Password", + $password, + ) ). " )" + ); + $sth->execute or die "can't insert into radcheck table: ". $sth->errstr; + + foreach my $attribute ( keys %radcheck ) { + my $sth = $icradius_dbh->prepare( + "INSERT INTO radcheck ( id, UserName, Attribute, Value ) VALUES ( ". + join(", ", map { $icradius_dbh->quote($_) } ( + '', + $username, + $attribute, + $radcheck{$attribute}, + ) ). " )" + ); + $sth->execute or die "can't insert into radcheck table: ". $sth->errstr; + } + + 1; +} + +sub icradius_rr_insert { + my( $username, $password, %radreply ) = @_; + + foreach my $attribute ( keys %radreply ) { + my $sth = $icradius_dbh->prepare( + "INSERT INTO radreply ( id, UserName, Attribute, Value ) VALUES ( ". + join(", ", map { $icradius_dbh->quote($_) } ( + '', + $username, + $attribute, + $radreply{$attribute}, + ) ). " )" + ); + $sth->execute or die "can't insert into radreply table: ". $sth->errstr; + } + + 1; +} + +=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 +added to the job queue (see L<FS::queue> and L<freeside-queued>) to be 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. + +(TODOC: cyrus config file) + +=cut + +sub delete { + my $self = shift; + + if ( defined( $FS::Record::dbdef->table('svc_acct_sm') ) ) { + return "Can't delete an account which has (svc_acct_sm) mail aliases!" + if $self->uid && qsearch( 'svc_acct_sm', { 'domuid' => $self->uid } ); + } + + return "Can't delete an account which is a (svc_forward) source!" + if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } ); + + return "Can't delete an account which is a (svc_forward) destination!" + if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } ); + + return "Can't delete an account with (svc_www) web service!" + if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } ); + + # what about records in session ? + + 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_main_invoice ( + qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } ) + ) { + unless ( defined($cust_main_invoice) ) { + warn "WARNING: something's wrong with qsearch"; + next; + } + my %hash = $cust_main_invoice->hash; + $hash{'dest'} = $self->email; + my $new = new FS::cust_main_invoice \%hash; + my $error = $new->replace($cust_main_invoice); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + foreach my $svc_domain ( + qsearch( 'svc_domain', { 'catchall' => $self->svcnum } ) + ) { + my %hash = new FS::svc_domain->hash; + $hash{'catchall'} = ''; + my $new = new FS::svc_domain \%hash; + my $error = $new->replace($svc_domain); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + my $error = $self->SUPER::delete; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + my( $username, $dir ) = ( + $self->username, + $self->dir, + ); + if ( $username && $shellmachine && ! $nossh_hack ) { + my $queue = new FS::queue { 'job' => 'Net::SSH::ssh_cmd' }; + $error = $queue->insert("root\@$shellmachine", eval qq("$userdel") ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + + } + + if ( $cyrus_server ) { + my $queue = new FS::queue { 'job' => 'FS::svc_acct::cyrus_delete' }; + $error = $queue->insert($self->username); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + } + + if ( $cp_server ) { + my $queue = new FS::queue { 'job' => 'FS::svc_acct::cp_delete' }; + $error = $queue->insert($self->username); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + } + + if ( $icradius_dbh ) { + + my $radcheck_queue = + new FS::queue { 'job' => 'FS::svc_acct::icradius_rc_delete' }; + $error = $radcheck_queue->insert( $self->username ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + + my $radreply_queue = + new FS::queue { 'job' => 'FS::svc_acct::icradius_rr_delete' }; + $error = $radreply_queue->insert( $self->username ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; +} + +sub cyrus_delete { + my $username = shift; + + my $client = Cyrus::IMAP::Admin->new($cyrus_server); + $client->authenticate( + -user => $cyrus_admin_user, + -mechanism => "login", + -password => $cyrus_admin_pass + ); + + my $rc = $client->setacl("user.$username", $cyrus_admin_user => 'all' ); + my $error = $client->error; + die $error if $error; + + $rc = $client->delete("user.$username"); + $error = $client->error; + die $error if $error; + + 1; +} + +sub cp_delete { + my( $username ) = @_; + my $app = new Net::APP ( $cp_server, + User => $cp_user, + Password => $cp_pass, + Domain => $mydomain, + Timeout => 60, + #Debug => 1, + ) or die "$@\n"; + + $app->delete_mailbox( + Mailbox => $username, + Domain => $mydomain, + ); + + die $app->message."\n" unless $app->ok; +} + +sub icradius_rc_delete { + my $username = shift; + + my $sth = $icradius_dbh->prepare( + 'DELETE FROM radcheck WHERE UserName = ?' + ); + $sth->execute($username) + or die "can't delete from radcheck table: ". $sth->errstr; + + 1; +} + +sub icradius_rr_delete { + my $username = shift; + + my $sth = $icradius_dbh->prepare( + 'DELETE FROM radreply WHERE UserName = ?' + ); + $sth->execute($username) + or die "can't delete from radreply table: ". $sth->errstr; + + 1; +} + +=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 added to the job queue (see L<FS::queue> and +L<freeside-queued>) to be 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 the default. 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, + 'domsvc' => $new->domsvc, + } ); + { + #no warnings 'numeric'; #alas, a 5.006-ism + local($^W) = 0; + return "Can't change uid!" if $old->uid != $new->uid; + } + + return "can't change username using Cyrus" + if $cyrus_server && $old->username ne $new->username; + + #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'; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + $error = $new->SUPER::replace($old); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + 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 ) { + my $queue = new FS::queue { + 'svcnum' => $new->svcnum, + 'job' => 'Net::SSH::ssh_cmd' + }; + $error = $queue->insert("root\@$shellmachine", eval qq("$usermod") ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + } + + if ( $cp_server && $old->username ne $new->username ) { + my $queue = new FS::queue { + 'svcnum' => $new->svcnum, + 'job' => 'FS::svc_acct::cp_rename' + }; + $error = $queue->insert( $old->username, $new->username ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + } + + if ( $cp_server && $old->_password ne $new->_password ) { + my $queue = new FS::queue { + 'svcnum' => $new->svcnum, + 'job' => 'FS::svc_acct::cp_change' + }; + $error = $queue->insert( $new->username, $new->_password ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + } + + if ( $icradius_dbh ) { + my $queue = new FS::queue { + 'svcnum' => $new->svcnum, + 'job' => 'FS::svc_acct::icradius_rc_replace' + }; + $error = $queue->insert( $new->username, + $new->_password, + ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; #no error +} + +sub icradius_rc_replace { + my( $username, $new_password ) = @_; + + my $sth = $icradius_dbh->prepare( + "UPDATE radcheck SET Value = ? WHERE UserName = ? and Attribute = ?" + ); + $sth->execute($new_password, $username, 'Password' ) + or die "can't update radcheck table: ". $sth->errstr; + + 1; +} + +sub cp_rename { + my ( $old_username, $new_username ) = @_; + + my $app = new Net::APP ( $cp_server, + User => $cp_user, + Password => $cp_pass, + Domain => $mydomain, + Timeout => 60, + #Debug => 1, + ) or die "$@\n"; + + $app->rename_mailbox( + Domain => $mydomain, + Old_Mailbox => $old_username, + New_Mailbox => $new_username, + ); + + die $app->message."\n" unless $app->ok; + +} + +sub cp_change { + my ( $username, $password ) = @_; + + my $app = new Net::APP ( $cp_server, + User => $cp_user, + Password => $cp_pass, + Domain => $mydomain, + Timeout => 60, + #Debug => 1, + ) or die "$@\n"; + + if ( $password =~ /^\*SUSPENDED\* (.*)$/ ) { + $password = $1; + $app->set_mailbox_status( + Domain => $mydomain, + Mailbox => $username, + Other => 'T', + Other_Bounce => 'T', + ); + } else { + $app->set_mailbox_status( + Domain => $mydomain, + Mailbox => $username, + Other => 'F', + Other_Bounce => 'F', + ); + } + die $app->message."\n" unless $app->ok; + + $app->change_mailbox( + Domain => $mydomain, + Mailbox => $username, + Password => $password, + ); + die $app->message."\n" unless $app->ok; + +} + +=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} eq '*' + ) { + $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 $error = $self->ut_numbern('svcnum') + || $self->ut_number('domsvc') + ; + return $error if $error; + + my $ulen = $usernamemax || $self->dbdef_table->column('username')->length; + if ( $username_uppercase ) { + $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i + or return "Illegal username: ". $recref->{username}; + $recref->{username} = $1; + } else { + $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/ + or return "Illegal username: ". $recref->{username}; + $recref->{username} = $1; + } + + if ( $username_letterfirst ) { + $recref->{username} =~ /^[a-z]/ or return "Illegal username"; + } elsif ( $username_letter ) { + $recref->{username} =~ /[a-z]/ or return "Illegal username"; + } + if ( $username_noperiod ) { + $recref->{username} =~ /\./ and return "Illegal username"; + } + unless ( $username_ampersand ) { + $recref->{username} =~ /\&/ and 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->part_svc_column('uid')->columnflag 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'; + +# $error = $self->ut_textn('finger'); +# return $error if $error; + $self->getfield('finger') =~ + /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\*\<\>]*)$/ + or return "Illegal finger: ". $self->getfield('finger'); + $self->setfield('finger', $1); + + $recref->{dir} =~ /^([\/\w\-\.\&]*)$/ + or return "Illegal directory"; + $recref->{dir} = $1; + return "Illegal directory" + if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component + return "Illegal directory" + if $recref->{dir} =~ /\&/ && ! $username_ampersand; + unless ( $recref->{dir} ) { + $recref->{dir} = $dir_prefix . '/'; + if ( $dirhash > 0 ) { + for my $h ( 1 .. $dirhash ) { + $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/'; + } + } elsif ( $dirhash < 0 ) { + for my $h ( reverse $dirhash .. -1 ) { + $recref->{dir} .= substr($recref->{username}, $h, 1). '/'; + } + } + $recref->{dir} .= $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->part_svc_column('slipip')->columnflag 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,$passwordmax})$/ ) { + $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} = '*'; + } elsif ( $recref->{_password} eq '!!' ) { + $recref->{_password} = '!!'; + } else { + #return "Illegal password"; + return "Illegal password: ". $recref->{_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; + my %reply = + map { + /^(radius_(.*))$/; + my($column, $attrib) = ($1, $2); + #$attrib =~ s/_/\-/g; + ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) ); + } grep { /^radius_/ && $self->getfield($_) } fields( $self->table ); + if ( $self->ip && $self->ip ne '0e0' ) { + $reply{'Framed-IP-Address'} = $self->ip; + } + %reply; +} + +=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; + ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) ); + } grep { /^rc_/ && $self->getfield($_) } fields( $self->table ); +} + +=item domain + +Returns the domain associated with this account. + +=cut + +sub domain { + my $self = shift; + if ( $self->domsvc ) { + #$self->svc_domain->domain; + my $svc_domain = $self->svc_domain + or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc; + $svc_domain->domain; + } else { + $mydomain or die "svc_acct.domsvc is null and no legacy domain config file"; + } +} + +=item svc_domain + +Returns the FS::svc_domain record for this account's domain (see +L<FS::svc_domain>. + +=cut + +sub svc_domain { + my $self = shift; + $self->{'_domsvc'} + ? $self->{'_domsvc'} + : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } ); +} + +=item cust_svc + +Returns the FS::cust_svc record for this account (see L<FS::cust_svc>). + +sub cust_svc { + my $self = shift; + qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } ); +} + +=item email + +Returns an email address associated with the account. + +=cut + +sub email { + my $self = shift; + $self->username. '@'. $self->domain; +} + +=item seconds_since TIMESTAMP + +Returns the number of seconds this account has been online since TIMESTAMP. +See L<FS::session> + +TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see +L<Time::Local> and L<Date::Parse> for conversion functions. + +=cut + +#note: POD here, implementation in FS::cust_svc +sub seconds_since { + my $self = shift; + $self->cust_svc->seconds_since(@_); +} + +=back + +=head1 BUGS + +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>, edit/part_svc.cgi from an installed web interface, +export.html from the base documentation, L<FS::Record>, L<FS::Conf>, +L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>, +L<freeside-queued>), 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..fa4f5c670 --- /dev/null +++ b/FS/FS/svc_acct_pop.pm @@ -0,0 +1,200 @@ +package FS::svc_acct_pop; + +use strict; +use vars qw( @ISA @EXPORT_OK @svc_acct_pop %svc_acct_pop ); +use FS::Record qw( qsearch qsearchs ); + +@ISA = qw( FS::Record Exporter ); +@EXPORT_OK = qw( popselector ); + +=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; + + $html = FS::svc_acct_pop::popselector( $popnum, $state ); + +=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') + ; + +} + +=item text + +Returns: + +"$city, $state ($ac)/$exch" + +=cut + +sub text { + my $self = shift; + $self->city. ', '. $self->state. + ' ('. $self->ac. ')/'. $self->exch. '-'. $self->loc; +} + +=back + +=head1 SUBROUTINES + +=over 4 + +=item popselector [ POPNUM [ STATE ] ] + +=cut + +sub popselector { + my( $popnum, $state ) = @_; + + unless ( @svc_acct_pop ) { #cache pop list + @svc_acct_pop = qsearch('svc_acct_pop', {} ); + %svc_acct_pop = (); + push @{$svc_acct_pop{$_->state}}, $_ foreach @svc_acct_pop; + } + + my $text = <<END; + <SCRIPT> + function opt(what,href,text) { + var optionName = new Option(text, href, false, false) + var length = what.length; + what.options[length] = optionName; + } + + function popstate_changed(what) { + state = what.options[what.selectedIndex].text; + for (var i = what.form.popnum.length;i > 0;i--) + what.form.popnum.options[i] = null; + what.form.popnum.options[0] = new Option("", "", false, true); +END + + foreach my $popstate ( sort { $a cmp $b } keys %svc_acct_pop ) { + $text .= "\nif ( state == \"$popstate\" ) {\n"; + + foreach my $pop ( @{$svc_acct_pop{$popstate}}) { + my $o_popnum = $pop->popnum; + my $poptext = $pop->text; + $text .= "opt(what.form.popnum, \"$o_popnum\", \"$poptext\");\n" + } + $text .= "}\n"; + } + + $text .= "}\n</SCRIPT>\n"; + + $text .= + qq!<SELECT NAME="popstate" SIZE=1 onChange="popstate_changed(this)">!. + qq!<OPTION> !; + $text .= "<OPTION>$_" foreach sort { $a cmp $b } keys %svc_acct_pop; + $text .= '</SELECT>'; #callback? return 3 html pieces? #'</TD><TD>'; + + $text .= qq!<SELECT NAME="popnum" SIZE=1><OPTION> !; + foreach my $pop ( @svc_acct_pop ) { + $text .= qq!<OPTION VALUE="!. $pop->popnum. '"'. + ( ( $popnum && $pop->popnum == $popnum ) ? ' SELECTED' : '' ). ">". + $pop->text; + } + $text .= '</SELECT>'; + + $text; + +} + +=back + +=head1 VERSION + +$Id: svc_acct_pop.pm,v 1.6 2001-12-18 06:29:30 ivan Exp $ + +=head1 BUGS + +It should be renamed to part_pop. + +popselector? putting web ui components in here? they should probably live +somewhere else... + +=head1 SEE ALSO + +L<FS::Record>, L<FS::svc_acct>, L<FS::part_pop_local>, 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..c92f1421f --- /dev/null +++ b/FS/FS/svc_acct_sm.pm @@ -0,0 +1,260 @@ +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 WARNING + +FS::svc_acct_sm is B<depreciated>. This class is only included for migration +purposes. See L<FS::svc_forward>. + +=head1 DESCRIPTION + +An FS::svc_acct_sm object represents a virtual mail alias. FS::svc_acct_sm +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.5 2001-09-06 20:41:59 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::svc_forward> + +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..84a102911 --- /dev/null +++ b/FS/FS/svc_domain.pm @@ -0,0 +1,452 @@ +package FS::svc_domain; + +use strict; +use vars qw( @ISA $whois_hack $conf $smtpmachine + @mxmachines @nsmachines $soadefaultttl $soaemail $soaexpire $soamachine + $soarefresh $soaretry $qshellmachine $nossh_hack +); +use Carp; +use Mail::Internet; +use Mail::Header; +use Date::Format; +use Net::Whois 1.0; +use Net::SSH; +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; +use FS::queue; + +@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; + + $smtpmachine = $conf->config('smtpmachine'); + + @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'); + + $qshellmachine = $conf->exists('qmailmachines') + ? $conf->config('shellmachine') + : ''; +}; + +=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 + +=item catchall - optional svcnum of an svc_acct record, designating an email catchall account. + +=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>). + +If a machine is defined in the I<shellmachine> configuration value, the +I<qmailmachines> configuration file exists, and the I<catchall> field points +to an an account with a home directory (see L<FS::svc_acct>), the command: + + [ -e $dir/.qmail-$qdomain-defualt ] || { + 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 supressed by setting $FS::svc_domain::nossh_hack true. + +a machine is defined +in the + +=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%d", 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; + + if ( $qshellmachine && $self->catchall && ! $nossh_hack ) { + + my $svc_acct = qsearchs( 'svc_acct', { 'svcnum' => $self->catchall } ) + or warn "WARNING: inserted unknown catchall: ". $self->catchall; + if ( $svc_acct && $svc_acct->dir ) { + my $qdomain = $self->domain; + $qdomain =~ s/\./:/g; #see manpage for 'dot-qmail': EXTENSION ADDRESSES + my ( $uid, $gid, $dir ) = ( + $svc_acct->uid, + $svc_acct->gid, + $svc_acct->dir, + ); + + my $queue = new FS::queue { + 'svcnum' => $self->svcnum, + 'job' => 'Net::SSH::ssh_cmd', + }; + $error = $queue->insert("root\@$qshellmachine", "[ -e $dir/.qmail-$qdomain-default ] || { touch $dir/.qmail-$qdomain-default; chown $uid:$gid $dir/.qmail-$qdomain-default; }" ); + + } + } + + ''; #no error +} + +=item delete + +Deletes this domain from the database. If there is an error, returns the +error, otherwise returns false. + +The corresponding FS::cust_svc record will be deleted as well. + +=cut + +sub delete { + my $self = shift; + + return "Can't delete a domain which has accounts!" + if qsearch( 'svc_acct', { 'domsvc' => $self->svcnum } ); + + return "Can't delete a domain with (svc_acct_sm) mail aliases!" + if defined( $FS::Record::dbdef->table('svc_acct_sm') ) + && qsearch('svc_acct_sm', { 'domsvc' => $self->svcnum } ); + + return "Can't delete a domain with (domain_record) zone entries!" + if qsearch('domain_record', { 'svcnum' => $self->svcnum } ); + + $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. + +=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 $x = $self->setfixed; + return $x unless ref($x); + #my $part_svc = $x; + + my $error = $self->ut_numbern('svcnum') + || $self->ut_numbern('catchall') + ; + return $error if $error; + + #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]->email ); + } + } + } + + #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; + + my $svc_acct = qsearchs( 'svc_acct', { 'svcnum' => $recref->{catchall} } ); + return "Unknown catchall" unless $svc_acct || ! $recref->{catchall}; + + $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; + carp "submit_internic depreciated"; +} + +=back + +=head1 VERSION + +$Id: svc_domain.pm,v 1.24 2002-02-20 01:03:09 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_forward.pm b/FS/FS/svc_forward.pm new file mode 100644 index 000000000..12f8b9236 --- /dev/null +++ b/FS/FS/svc_forward.pm @@ -0,0 +1,470 @@ +package FS::svc_forward; + +use strict; +use vars qw( @ISA $nossh_hack $conf $shellmachine @qmailmachines + @vpopmailmachines ); +use Net::SSH qw(ssh); +use FS::Conf; +use FS::Record qw( fields qsearch qsearchs dbh ); +use FS::svc_Common; +use FS::cust_svc; +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_forward'} = sub { + $conf = new FS::Conf; + if ( $conf->exists('qmailmachines') ) { + $shellmachine = $conf->config('shellmachine') + } else { + $shellmachine = ''; + } + if ( $conf->exists('vpopmailmachines') ) { + @vpopmailmachines = $conf->config('vpopmailmachines'); + } else { + @vpopmailmachines = (); + } +}; + +=head1 NAME + +FS::svc_forward - Object methods for svc_forward records + +=head1 SYNOPSIS + + use FS::svc_forward; + + $record = new FS::svc_forward \%hash; + $record = new FS::svc_forward { '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_forward object represents a mail forwarding alias. FS::svc_forward +inherits from FS::Record. The following fields are currently supported: + +=over 4 + +=item svcnum - primary key (assigned automatcially for new accounts) + +=item srcsvc - svcnum of the source of the forward (see L<FS::svc_acct>) + +=item dstsvc - svcnum of the destination of the forward (see L<FS::svc_acct>) + +=item dst - foreign destination (email address) - forward not local to freeside + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new mail forwarding alias. To add the mail forwarding alias to the +database, see L<"insert">. + +=cut + +sub table { 'svc_forward'; } + +=item insert + +Adds this mail forwarding 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 value (see L<FS::Conf>) vpopmailmachines exists, then +the command: + + [ -d $vpopdir/domains/$domain/$source ] && { + echo "$destination" >> $vpopdir/domains/$domain/$username/.$qmail + chown $vpopuid:$vpopgid $vpopdir/domains/$domain/$username/.$qmail + } + +is executed on each vpopmailmachine via ssh (see the vpopmail documentation). +This behaviour can be supressed by setting $FS::svc_forward::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'; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + $error = $self->check; + return $error if $error; + + $error = $self->SUPER::insert; + if ($error) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + my $svc_acct = qsearchs( 'svc_acct', { 'svcnum' => $self->srcsvc } ); + my $username = $svc_acct->username; + my $domain = $svc_acct->domain; + my $destination; + if ($self->dstsvc) { + $destination = $self->dstsvc_acct->email; + } else { + $destination = $self->dst; + } + + foreach my $vpopmailmachine ( @vpopmailmachines ) { + my($machine, $vpopdir, $vpopuid, $vpopgid) = split(/\s+/, $vpopmailmachine); + my $queue = new FS::queue { + 'svcnum' => $self->svcnum, + 'job' => 'Net::SSH::ssh_cmd', + }; + # should be neater + my $error = $queue->insert("root\@$machine","[ -d $vpopdir/domains/$domain/$username ] && { echo \"$destination\" >> $vpopdir/domains/$domain/$username/.qmail; chown $vpopuid:$vpopgid $vpopdir/domains/$domain/$username/.qmail; }") + unless $nossh_hack; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; #no error + +} + +=item delete + +Deletes this mail forwarding 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. + +If the configuration value vpopmailmachines exists, then the command: + + { sed -e '/^$destination/d' < + $vpopdir/domains/$srcdomain/$srcusername/.qmail > + $vpopdir/domains/$srcdomain/$srcusername/.qmail.temp; + mv $vpopdir/domains/$srcdomain/$srcusername/.qmail.temp + $vpopdir/domains/$srcdomain/$srcusername/.qmail; + chown $vpopuid.$vpopgid $vpopdir/domains/$srcdomain/$srcusername/.qmail; } + + +is executed on each vpopmailmachine via ssh. This behaviour can be supressed +by setting $FS::svc_forward_nossh_hack true. + +=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; + + my $error = $self->SUPER::delete; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + my $svc_acct = $self->srcsvc_acct; + my $username = $svc_acct->username; + my $domain = $svc_acct->domain; + my $destination; + if ($self->dstsvc) { + $destination = $self->dstsvc_acct->email; + } else { + $destination = $self->dst; + } + foreach my $vpopmailmachine ( @vpopmailmachines ) { + my($machine, $vpopdir, $vpopuid, $vpopgid) = + split(/\s+/, $vpopmailmachine); + my $queue = new FS::queue { 'job' => 'Net::SSH::ssh_cmd' }; + # should be neater + my $error = $queue->insert("root\@$machine", + "sed -e '/^$destination/d' " . + "< $vpopdir/domains/$domain/$username/.qmail" . + "> $vpopdir/domains/$domain/$username/.qmail.temp; " . + "mv $vpopdir/domains/$domain/$username/.qmail.temp " . + "$vpopdir/domains/$domain/$username/.qmail; " . + "chown $vpopuid.$vpopgid $vpopdir/domains/$domain/$username/.qmail;" + ) + unless $nossh_hack; + + if ($error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; +} + + +=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 vpopmailmachines exists, then the command: + + { sed -e '/^$destination/d' < + $vpopdir/domains/$srcdomain/$srcusername/.qmail > + $vpopdir/domains/$srcdomain/$srcusername/.qmail.temp; + mv $vpopdir/domains/$srcdomain/$srcusername/.qmail.temp + $vpopdir/domains/$srcdomain/$srcusername/.qmail; + chown $vpopuid.$vpopgid $vpopdir/domains/$srcdomain/$srcusername/.qmail; } + + +is executed on each vpopmailmachine via ssh. This behaviour can be supressed +by setting $FS::svc_forward_nossh_hack true. + +Also, if the configuration value vpopmailmachines exists, then the command: + + [ -d $vpopdir/domains/$domain/$source ] && { + echo "$destination" >> $vpopdir/domains/$domain/$username/.$qmail + chown $vpopuid:$vpopgid $vpopdir/domains/$domain/$username/.$qmail + } + +is executed on each vpopmailmachine via ssh. This behaviour can be supressed +by setting $FS::svc_forward_nossh_hack true. + +=cut + +sub replace { + my ( $new, $old ) = ( shift, shift ); + + if ( $new->srcsvc != $old->srcsvc + && ( $new->dstsvc != $old->dstsvc + || ! $new->dstsvc && $new->dst ne $old->dst + ) + ) { + return "Can't change both source and destination of a mail forward!" + } + + 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 $error = $new->SUPER::replace($old); + if ($error) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + my $old_svc_acct = $old->srcsvc_acct; + my $old_username = $old_svc_acct->username; + my $old_domain = $old_svc_acct->domain; + my $destination; + if ($old->dstsvc) { + $destination = $old->dstsvc_acct->email; + } else { + $destination = $old->dst; + } + foreach my $vpopmailmachine ( @vpopmailmachines ) { + my($machine, $vpopdir, $vpopuid, $vpopgid) = + split(/\s+/, $vpopmailmachine); + my $queue = new FS::queue { + 'svcnum' => $new->svcnum, + 'job' => 'Net::SSH::ssh_cmd', + }; + # should be neater + my $error = $queue->insert("root\@$machine", + "sed -e '/^$destination/d' " . + "< $vpopdir/domains/$old_domain/$old_username/.qmail" . + "> $vpopdir/domains/$old_domain/$old_username/.qmail.temp; " . + "mv $vpopdir/domains/$old_domain/$old_username/.qmail.temp " . + "$vpopdir/domains/$old_domain/$old_username/.qmail; " . + "chown $vpopuid.$vpopgid " . + "$vpopdir/domains/$old_domain/$old_username/.qmail;" + ) + unless $nossh_hack; + + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + } + + #false laziness with stuff in insert, should subroutine + my $svc_acct = qsearchs( 'svc_acct', { 'svcnum' => $new->srcsvc } ); + my $username = $svc_acct->username; + my $domain = $svc_acct->domain; + if ($new->dstsvc) { + $destination = $new->dstsvc_acct->email; + } else { + $destination = $new->dst; + } + + foreach my $vpopmailmachine ( @vpopmailmachines ) { + my($machine, $vpopdir, $vpopuid, $vpopgid) = split(/\s+/, $vpopmailmachine); + my $queue = new FS::queue { + 'svcnum' => $new->svcnum, + 'job' => 'Net::SSH::ssh_cmd', + }; + # should be neater + my $error = $queue->insert("root\@$machine","[ -d $vpopdir/domains/$domain/$username ] && { echo \"$destination\" >> $vpopdir/domains/$domain/$username/.qmail; chown $vpopuid:$vpopgid $vpopdir/domains/$domain/$username/.qmail; }") + unless $nossh_hack; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "queueing job (transaction rolled back): $error"; + } + } + #end subroutinable bits + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; +} + +=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 mail forwarding 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 $x = $self->setfixed; + return $x unless ref($x); + #my $part_svc = $x; + + my $error = $self->ut_numbern('svcnum') + || $self->ut_number('srcsvc') + || $self->ut_numbern('dstsvc') + ; + return $error if $error; + + return "Unknown srcsvc" unless $self->srcsvc_acct; + + return "Both dstsvc and dst were defined; one one can be specified" + if $self->dstsvc && $self->dst; + + return "one of dstsvc or dst is required" + unless $self->dstsvc || $self->dst; + + #return "Unknown dstsvc: $dstsvc" unless $self->dstsvc_acct || ! $self->dstsvc; + return "Unknown dstsvc" + unless qsearchs('svc_acct', { 'svcnum' => $self->dstsvc } ) + || ! $self->dstsvc; + + + if ( $self->dst ) { + $self->dst =~ /^([\w\.\-]+)\@(([\w\-]+\.)+\w+)$/ + or return "Illegal dst: ". $self->dst; + $self->dst("$1\@$2"); + } else { + $self->dst(''); + } + + ''; #no error +} + +=item srcsvc_acct + +Returns the FS::svc_acct object referenced by the srcsvc column. + +=cut + +sub srcsvc_acct { + my $self = shift; + qsearchs('svc_acct', { 'svcnum' => $self->srcsvc } ); +} + +=item dstsvc_acct + +Returns the FS::svc_acct object referenced by the srcsvc column, or false for +forwards not local to freeside. + +=cut + +sub dstsvc_acct { + my $self = shift; + qsearchs('svc_acct', { 'svcnum' => $self->dstsvc } ); +} + +=back + +=head1 VERSION + +$Id: svc_forward.pm,v 1.11 2002-02-20 01:03:09 ivan Exp $ + +=head1 BUGS + +The remote commands should be configurable. + +=head1 SEE ALSO + +L<FS::Record>, L<FS::Conf>, L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, +L<FS::svc_acct>, L<FS::svc_domain>, L<Net::SSH>, L<ssh>, L<dot-qmail>, +schema.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..f09a3f89d --- /dev/null +++ b/FS/FS/svc_www.pm @@ -0,0 +1,300 @@ +package FS::svc_www; + +use strict; +use vars qw(@ISA $conf $apacheroot $apachemachine $apacheip $nossh_hack ); +#use FS::Record qw( qsearch qsearchs ); +use FS::Record qw( qsearchs dbh ); +use FS::svc_Common; +use FS::cust_svc; +use FS::domain_record; +use FS::svc_acct; +use FS::svc_domain; +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'); + $apacheip = $conf->config('apacheip'); +}; + +=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 = $self->check; + return $error if $error; + + local $SIG{HUP} = 'IGNORE'; + local $SIG{INT} = 'IGNORE'; + local $SIG{QUIT} = 'IGNORE'; + local $SIG{TERM} = 'IGNORE'; + local $SIG{TSTP} = 'IGNORE'; + local $SIG{PIPE} = 'IGNORE'; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + #if ( $self->recnum =~ /^([\w\-]+|\@)\.(([\w\.\-]+\.)+\w+)$/ ) { + if ( $self->recnum =~ /^([\w\-]+|\@)\.(\d+)$/ ) { + my( $reczone, $domain_svcnum ) = ( $1, $2 ); + unless ( $apacheip ) { + $dbh->rollback if $oldAutoCommit; + return "Configuration option apacheip not set; can't autocreate A record"; + #"for $reczone". $svc_domain->domain; + } + my $domain_record = new FS::domain_record { + 'svcnum' => $domain_svcnum, + 'reczone' => $reczone, + 'recaf' => 'IN', + 'rectype' => 'A', + 'recdata' => $apacheip, + }; + $error = $domain_record->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + $self->recnum($domain_record->recnum); + } + + $error = $self->SUPER::insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $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" + ); + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; +} + +=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 web virtual host. 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; + + if ( $self->recnum =~ /^(\d+)$/ ) { + + $self->recnum($1); + return "Unknown recnum: ". $self->recnum + unless qsearchs('domain_record', { 'recnum' => $self->recnum } ); + + } elsif ( $self->recnum =~ /^([\w\-]+|\@)\.(([\w\.\-]+\.)+\w+)$/ ) { + + my( $reczone, $domain ) = ( $1, $2 ); + + my $svc_domain = qsearchs( 'svc_domain', { 'domain' => $domain } ) + or return "unknown domain $domain (recnum $1.$2)"; + + my $domain_record = qsearchs( 'domain_record', { + 'reczone' => $reczone, + 'svcnum' => $svc_domain->svcnum, + }); + + if ( $domain_record ) { + $self->recnum($domain_record->recnum); + } else { + #insert will create it + #$self->recnum("$reczone.$domain"); + $self->recnum("$reczone.". $svc_domain->svcnum); + } + + } else { + return "Illegal recnum: ". $self->recnum; + } + + return "Unknown usersvc (svc_acct.svcnum): ". $self->usersvc + unless qsearchs('svc_acct', { 'svcnum' => $self->usersvc } ); + + ''; #no error +} + +=back + +=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. + +=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..28edf59c3 --- /dev/null +++ b/FS/MANIFEST @@ -0,0 +1,113 @@ +Changes +MANIFEST +MANIFEST.SKIP +Makefile.PL +README +bin/freeside-bill +bin/freeside-daily +bin/freeside-email +bin/freeside-queued +bin/freeside-apply-credits +bin/freeside-adduser +bin/freeside-setinvoice +bin/freeside-overdue +bin/freeside-receivables-report +bin/freeside-tax-report +bin/freeside-cc-receipts-report +bin/freeside-credit-report +FS.pm +FS/CGI.pm +FS/Conf.pm +FS/ConfItem.pm +FS/Record.pm +FS/SearchCache.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_credit_bill.pm +FS/cust_main.pm +FS/cust_main_county.pm +FS/cust_main_invoice.pm +FS/cust_pay.pm +FS/cust_bill_event.pm +FS/cust_bill_pay.pm +FS/cust_pay_batch.pm +FS/cust_pkg.pm +FS/cust_refund.pm +FS/cust_credit_refund.pm +FS/cust_svc.pm +FS/part_bill_event.pm +FS/part_pkg.pm +FS/part_pop_local.pm +FS/part_referral.pm +FS/part_svc.pm +FS/part_svc_column.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 +FS/domain_record.pm +FS/prepay_credit.pm +FS/svc_www.pm +FS/svc_forward.pm +FS/raddb.pm +FS/queue.pm +FS/queue_arg.pm +t/agent.t +t/agent_type.t +t/CGI.t +t/Conf.t +t/ConfItem.t +t/cust_bill.t +t/cust_bill_event.t +t/cust_bill_pay.t +t/cust_bill_pkg.t +t/cust_credit.t +t/cust_credit_bill.t +t/cust_credit_refund.t +t/cust_main.t +t/cust_main_county.t +t/cust_main_invoice.t +t/cust_pay.t +t/cust_pay_batch.t +t/cust_pkg.t +t/cust_refund.t +t/cust_svc.t +t/domain_record.t +t/nas.t +t/part_bill_event.t +t/part_pkg.t +t/part_pop_local.t +t/part_referral.t +t/part_svc.t +t/part_svc_column.t +t/pkg_svc.t +t/port.t +t/prepay_credit.t +t/Record.t +t/session.t +t/svc_acct.t +t/svc_acct_pop.t +t/svc_acct_sm.t +t/svc_Common.t +t/svc_domain.t +t/svc_forward.t +t/svc_www.t +t/type_pkgs.t +t/queue.t +t/queue_arg.t +t/UID.t +t/raddb.t 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-adduser b/FS/bin/freeside-adduser new file mode 100644 index 000000000..9d424634b --- /dev/null +++ b/FS/bin/freeside-adduser @@ -0,0 +1,57 @@ +#!/usr/bin/perl -w +# +# $Id: freeside-adduser,v 1.4 2002-02-06 14:58:05 ivan Exp $ + +use strict; +use vars qw($opt_h $opt_c $opt_s); +use Getopt::Std; + +my $FREESIDE_CONF = "/usr/local/etc/freeside"; + +getopts("ch:s:"); +die &usage if $opt_c && ! $opt_h; +my $user = shift or die &usage; + +if ( $opt_h ) { + my @args = ( 'htpasswd' ); + push @args, '-c' if $opt_c; + push @args, $opt_h, $user; + system(@args) == 0 or die "htpasswd failed: $?"; +} + +my $secretfile = $opt_s || 'secrets'; + +open(MAPSECRETS,">>$FREESIDE_CONF/mapsecrets") + or die "can't open $FREESIDE_CONF/mapsecrets: $!"; +print MAPSECRETS "$user $secretfile\n"; +close MAPSECRETS or die "can't close $FREESIDE_CONF/mapsecrets: $!"; + +sub usage { + die "Usage:\n\n freeside-adduser [ -h htpasswd_file [ -c ] ] [ -s secretfile ] username" +} + +=head1 NAME + +freeside-adduser - Command line interface to add (freeside) users. + +=head1 SYNOPSIS + + freeside-adduser [ -h htpasswd_file [ -c ] ] [ -s secretfile ] username + +=head1 DESCRIPTION + +Adds a user to the Freeside billing system. This is for adding users (internal +sales/tech folks) to the web interface, not for adding customer accounts. + + -h: Also call htpasswd for this user with the given filename + + -c: Passed to htpasswd + + -s: Specify an alternate secret file + +=head1 SEE ALSO + +L<htpasswd>, base Freeside documentation + +=cut + diff --git a/FS/bin/freeside-apply-credits b/FS/bin/freeside-apply-credits new file mode 100755 index 000000000..ea6a7bdd0 --- /dev/null +++ b/FS/bin/freeside-apply-credits @@ -0,0 +1,21 @@ +#!/usr/bin/perl -Tw + +use strict; +use vars qw( $user $cust_main @customers ); +use FS::UID qw(adminsuidsetup); +use FS::Record qw(qsearch); +use FS::cust_main; + +$user = shift or die &usage; +&adminsuidsetup( $user ); + +my @customers = qsearch('cust_main', {} ); +die "No customers" unless (scalar(@customers) > 0); + +foreach $cust_main (@customers) { + print "Applying credits for customer #". $cust_main->custnum; + $cust_main->apply_credits; +} + + + diff --git a/FS/bin/freeside-bill b/FS/bin/freeside-bill new file mode 100755 index 000000000..49ad4a768 --- /dev/null +++ b/FS/bin/freeside-bill @@ -0,0 +1,128 @@ +#!/usr/bin/perl -w +# don't take any world-facing input +#!/usr/bin/perl -Tw + +use strict; +use Fcntl qw(:flock); +use Date::Parse; +use Getopt::Std; +use FS::UID qw(adminsuidsetup); +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_d $opt_p); +getopts("acd:p"); +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)= $opt_d ? str2time($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 ( + ( $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 ($opt_p) { + $cust_main->apply_payments; + $cust_main->apply_credits; + } + + if ($opt_c) { + $error=$cust_main->collect( 'invoice_time' => $time); + warn "Error collecting from customer #" . $cust_main->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 [ -p ] ] [ -d 'date' ] user [ custnum custnum ... ]\n"; +} + +=head1 NAME + +freeside-bill - Command line (crontab, script) interface to customer billing. + +=head1 SYNOPSIS + + freeside-bill [ -c [ -p ] [ -a ] ] [ -d 'date' ] user [ custnum custnum ... ] + +=head1 DESCRIPTION + +This script is deprecated in 1.4.0. You should use freeside-daily instead. + +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). + + -p: Apply unapplied payments and credits before collecting (you probably want + this too) + + -a: Call collect even if there isn't a new invoice (probably a bad idea for + daily use) + + -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 BUGS + +=head1 SEE ALSO + +L<freeside-daily>, L<FS::cust_main>, config.html from the base documentation + +=cut + diff --git a/FS/bin/freeside-cc-receipts-report b/FS/bin/freeside-cc-receipts-report new file mode 100755 index 000000000..2713af397 --- /dev/null +++ b/FS/bin/freeside-cc-receipts-report @@ -0,0 +1,231 @@ +#!/usr/bin/perl -Tw + +use strict; +use Date::Parse; +use Time::Local; +use Getopt::Std; +use FS::Conf; +use FS::UID qw(adminsuidsetup); +use FS::Record qw(qsearch qsearchs); +use FS::cust_pay; +use FS::cust_pay_batch; + +# 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_d $opt_s); +getopts("vped:s:"); #switches + +#we're at now now (and later). +my($_enddate)= $main::opt_d ? str2time($main::opt_d) : $^T; +my($_startdate)= $main::opt_d ? str2time($main::opt_s) : $^T; + +# Get the current month +my ($ssec,$smin,$shour,$smday,$smon,$syear) = + (localtime($_startdate) )[0,1,2,3,4,5]; +$syear+=1900; +$smon++; + +# Get the current month +my ($esec,$emin,$ehour,$emday,$emon,$eyear) = + (localtime($_enddate) )[0,1,2,3,4,5]; +$eyear+=1900; +$emon++; + +# 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(@cust_pays)=qsearch('cust_pay',{}); +if (scalar(@cust_pays) == 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 R E C E I P T S for period beginning: $smon/$smday/$syear and ending $emon/$emday/$eyear\n\n~; +} + +if ($email && $main::opt_e) +{ + open (MAIL, "|$mail_program"); + print MAIL <<END +To: $email +From: Account Processor +Subject: Receivables + + +C R E D I T C A R D R E C E I P T S for period beginning: $smon/$smday/$syear and ending $emon/$emday/$eyear + +END +} + +my $uninvoiced = 0; +my $total = 0; +my $taxed = 0; +my $untaxed = 0; +my $total_tax = 0; + +# Now I can start looping +foreach my $cust_pay (@cust_pays) +{ + my $_date = $cust_pay->getfield('_date'); + my $invnum = $cust_pay->getfield('invnum'); + my $paid = $cust_pay->getfield('paid'); + my $payby = $cust_pay->getfield('payby'); + + + if ($_date >= $_startdate && $_date <= $_enddate && $payby =~ 'CARD') { + $total += $paid; + + $uninvoiced += $cust_pay->unapplied; + my @cust_bill_pays = $cust_pay->cust_bill_pay; + foreach my $cust_bill_pay (@cust_bill_pays) { + my $invoice_amt =0; + my $invoice_tax =0; + my(@cust_bill_pkgs)= $cust_bill_pay->cust_bill->cust_bill_pkg; + foreach my $cust_bill_pkg (@cust_bill_pkgs) { + + my $recur = $cust_bill_pkg->getfield('recur'); + my $setup = $cust_bill_pkg->getfield('setup'); + my $pkgnum = $cust_bill_pkg->getfield('pkgnum'); + + if ($pkgnum == 0) { + $invoice_tax += $recur; + $invoice_tax += $setup; + } else { + $invoice_amt += $recur; + $invoice_amt += $setup; + } + + } + + if ($invoice_tax > 0) { + if ($invoice_amt != $paid) { + # attempt to prorate partially paid invoices + $total_tax += $paid / ($invoice_amt + $invoice_tax) * $invoice_tax; + $taxed += $paid / ($invoice_amt + $invoice_tax) * $invoice_amt; + } else { + $total_tax += $invoice_tax; + $taxed += $invoice_amt; + } + } else { + $untaxed += $paid; + } + + } + + } + +} + +if ($main::opt_v) { + printf(qq{\n%25s%14.2f\n}, "Uninvoiced", $uninvoiced); + printf(qq{%25s%14.2f\n}, "Untaxed", $untaxed); + printf(qq{%25s%14.2f\n}, "Taxed", $taxed); + printf(qq{%25s%14.2f\n}, "Tax", $total_tax); + printf(qq{\n%39s\n%39.2f\n}, "=========", $total); +} + +# Now I need to close LPR and EMAIL if they were open +if($lpr && $main::opt_p) +{ + printf(LPR qq{\n%25s%14.2f\n}, "Uninvoiced", $uninvoiced); + printf(LPR qq{%25s%14.2f\n}, "Untaxed", $untaxed); + printf(LPR qq{%25s%14.2f\n}, "Taxed", $taxed); + printf(LPR qq{%25s%14.2f\n}, "Tax", $total_tax); + printf(LPR qq{\n%39s\n%39.2f\n}, "=========", $total); + close LPR || die "Could not close printer: $lpr\n"; +} +if($email && $main::opt_e) +{ + printf(MAIL qq{\n%25s%14.2f\n}, "Untaxed", $untaxed); + printf(MAIL qq{%25s%14.2f\n}, "Taxed", $taxed); + printf(MAIL qq{%25s%14.2f\n}, "Tax", $total_tax); + printf(MAIL qq{\n%39s\n%39.2f\n}, "=========", $total); + close MAIL || die "Could not close printer: $email\n"; +} + + +# subroutines +sub untaint_argv { + foreach $_ ( $[ .. $#ARGV ) { #untaint @ARGV + $ARGV[$_] =~ /^([\w\-\/ :]*)$/ || die "Illegal argument \"$ARGV[$_]\""; + $ARGV[$_]=$1; + } +} + +sub usage { + die "Usage:\n\n freeside-tax-report [-v] [-p] [-e] user\n"; +} + +=head1 NAME + +freeside-tax-report - Prints or emails sales taxes invoiced in a given period. + +=head1 SYNOPSIS + + freeside-tax-report [-v] [-p] [-e] user + +=head1 DESCRIPTION + +Prints or emails sales taxes invoiced in a given period. + +-v: Verbose - Prints records to STDOUT. + +-p: Print to printer lpr as found in the conf directory. + +-e: Email output to user found in the Conf email file. + +user: From the mapsecrets file - see config.html from the base documentation + +=head1 VERSION + +$Id: freeside-cc-receipts-report,v 1.1 2002-02-22 23:18:32 jeff 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-cc-receipts-report,v $ +Revision 1.1 2002-02-22 23:18:32 jeff +add some reporting features + +Revision 1.2 2002/02/19 14:24:53 jeff +might be functional now + +Revision 1.1 2000/09/20 19:25:19 jeff +local modifications + +Revision 1.1 2000/05/13 21:57:56 ivan +add print_batch script from Joel Griffiths + + +=cut + + diff --git a/FS/bin/freeside-credit-report b/FS/bin/freeside-credit-report new file mode 100755 index 000000000..4307a21b0 --- /dev/null +++ b/FS/bin/freeside-credit-report @@ -0,0 +1,184 @@ +#!/usr/bin/perl -Tw + +use strict; +use Date::Parse; +use Time::Local; +use Getopt::Std; +use FS::Conf; +use FS::UID qw(adminsuidsetup); +use FS::Record qw(qsearch); +use FS::cust_credit; + +# 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_d $opt_s); +getopts("vped:s:"); #switches + +#we're at now now (and later). +my($_enddate)= $main::opt_d ? str2time($main::opt_d) : $^T; +my($_startdate)= $main::opt_s ? str2time($main::opt_s) : $^T; + +# Get the current month +my ($ssec,$smin,$shour,$smday,$smon,$syear) = + (localtime($_startdate) )[0,1,2,3,4,5]; +$syear+=1900; +$smon++; + +# Get the current month +my ($esec,$emin,$ehour,$emday,$emon,$eyear) = + (localtime($_enddate) )[0,1,2,3,4,5]; +$eyear+=1900; +$emon++; + +# 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(@cust_credits)=qsearch('cust_credit',{}); +if (scalar(@cust_credits) == 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~ I N H O U S E C R E D I T S for period beginning: $smon/$smday/$syear and ending $emon/$emday/$eyear\n\n~; +} + +if ($email && $main::opt_e) +{ + open (MAIL, "|$mail_program"); + print MAIL <<END +To: $email +From: Account Processor +Subject: In House Credits + + +I N H O U S E C R E D I T S for period beginning: $smon/$smday/$syear and ending $emon/$emday/$eyear + +END +} + +my $total = 0; + +# Now I can start looping +foreach my $cust_credit (@cust_credits) +{ + my $_date = $cust_credit->getfield('_date'); + my $amount = $cust_credit->getfield('amount'); + my $credited = $cust_credit->getfield('credited'); + + + if ($_date >= $_startdate && $_date <= $_enddate) { + $total += $amount; + + my ($sec,$min,$hour,$mday,$mon,$year) = + (localtime($_date) )[0,1,2,3,4,5]; + $mon++; + + } + +} + +if ($main::opt_v) { + printf(qq{\n\n%25s%14.2f\n}, "Credits Offered", $total); + printf(qq{\n%39s\n%39.2f\n}, "=========", $total); +} + +# Now I need to close LPR and EMAIL if they were open +if($lpr && $main::opt_p) +{ + printf(LPR qq{\n\n%25s%14.2f\n}, "Credits Offered", $total); + printf(LPR qq{\n%39s\n%39.2f\n}, "=========", $total); + close LPR || die "Could not close printer: $lpr\n"; +} +if($email && $main::opt_e) +{ + printf(MAIL qq{\n\n%25s%14.2f\n}, "Credits Offered", $total); + printf(MAIL qq{\n%39s\n%39.2f\n}, "=========", $total); + close MAIL || die "Could not close printer: $email\n"; +} + + +# subroutines +sub untaint_argv { + foreach $_ ( $[ .. $#ARGV ) { #untaint @ARGV + $ARGV[$_] =~ /^([\w\-\/ :]*)$/ || die "Illegal argument \"$ARGV[$_]\""; + $ARGV[$_]=$1; + } +} + +sub usage { + die "Usage:\n\n freeside-credit-report [-v] [-p] [-e] user\n"; +} + +=head1 NAME + +freeside-credit-report - Prints or emails in house credits offered in a given period. + +=head1 SYNOPSIS + + freeside-credit-report [-v] [-p] [-e] user + +=head1 DESCRIPTION + +Prints or emails in house credits offered in a given period. + +-v: Verbose - Prints records to STDOUT. + +-p: Print to printer lpr as found in the conf directory. + +-e: Email output to user found in the Conf email file. + +user: From the mapsecrets file - see config.html from the base documentation + +=head1 VERSION + +$Id: freeside-credit-report,v 1.1 2002-02-22 23:18:32 jeff 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-credit-report,v $ +Revision 1.1 2002-02-22 23:18:32 jeff +add some reporting features + +Revision 1.1 2002/02/19 14:24:53 jeff +might be functional now + +Revision 1.1 2000/09/20 19:25:19 jeff +local modifications + +Revision 1.1 2000/05/13 21:57:56 ivan +add print_batch script from Joel Griffiths + + +=cut + + diff --git a/FS/bin/freeside-daily b/FS/bin/freeside-daily new file mode 100755 index 000000000..8d839cb21 --- /dev/null +++ b/FS/bin/freeside-daily @@ -0,0 +1,90 @@ +#!/usr/bin/perl -w + +use strict; +use Fcntl qw(:flock); +use Date::Parse; +use Getopt::Std; +use FS::UID qw(adminsuidsetup); +use FS::Record qw(qsearch qsearchs); +use FS::cust_main; + +&untaint_argv; #what it sounds like (eww) +use vars qw($opt_d); +getopts("d:"); +my $user = shift or die &usage; + +adminsuidsetup $user; + +my @cust_main = @ARGV + ? map { qsearchs('cust_main', { custnum => $_ } ) } @ARGV + : qsearch('cust_main', {} ) +; + +#we're at now now (and later). +my($time)= $opt_d ? str2time($opt_d) : $^T; + +my($cust_main,%saw); +foreach $cust_main ( @cust_main ) { + + my $error; + + $error = $cust_main->bill( 'time' => $time ); + warn "Error billing, custnum ". $cust_main->custnum. ": $error" if $error; + + $cust_main->apply_payments; + $cust_main->apply_credits; + + $error=$cust_main->collect( 'invoice_time' => $time ); + warn "Error collecting, custnum". $cust_main->custnum. ": $error" if $error; + +} + +# 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-daily [ -d 'date' ] user [ custnum custnum ... ]\n"; +} + +=head1 NAME + +freeside-daily - Run daily billing and invoice collection events. + +=head1 SYNOPSIS + + freeside-daily [ -d 'date' ] user [ custnum custnum ... ] + +=head1 DESCRIPTION + +Bills customers and runs invoice collection events. Should be run from +crontab daily. + +This script replaces freeside-bill from 1.3.1. + +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>. + + -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 BUGS + +=head1 SEE ALSO + +L<FS::cust_main>, config.html from the base documentation + +=cut + diff --git a/FS/bin/freeside-email b/FS/bin/freeside-email new file mode 100755 index 000000000..c7ff41114 --- /dev/null +++ b/FS/bin/freeside-email @@ -0,0 +1,61 @@ +#!/usr/bin/perl -Tw + +use strict; +use FS::UID qw(adminsuidsetup); +use FS::Conf; +use FS::Record qw(qsearch); +use FS::svc_acct; + +&untaint_argv; #what it sounds like (eww) +my $user = shift or die &usage; + +adminsuidsetup $user; + +my $conf = new FS::Conf; +my $domain = $conf->config('domain'); + +my @svc_acct = qsearch('svc_acct', {}); +my @usernames = map $_->username, @svc_acct; +my @emails = map "$_\@$domain", @usernames; + +print join("\n", @emails), "\n"; + +# 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-email user\n"; +} + +=head1 NAME + +freeside-email - Prints email addresses of all users on STDOUT + +=head1 SYNOPSIS + + freeside-email user + +=head1 DESCRIPTION + +Prints the email addresses of all customers on STDOUT, separated by newlines. + +user: From the mapsecrets file - see config.html from the base documentation + +=head1 VERSION + +$Id: freeside-email,v 1.1 2001-05-15 07:52:34 ivan Exp $ + +=head1 BUGS + +=head1 SEE ALSO + +=cut + diff --git a/FS/bin/freeside-overdue b/FS/bin/freeside-overdue new file mode 100755 index 000000000..db99e62b4 --- /dev/null +++ b/FS/bin/freeside-overdue @@ -0,0 +1,193 @@ +#!/usr/bin/perl -w + +use strict; +use vars qw( $days_to_pay $cust_main $cust_pkg + $cust_svc $svc_acct ); +use Getopt::Std; +use FS::cust_main; +use FS::cust_pkg; +use FS::cust_svc; +use FS::svc_acct; +use FS::Record qw(qsearch qsearchs); +use FS::UID qw(adminsuidsetup); + +&untaint_argv; +my %opt; +getopts('ed:qpl:scbyoi', \%opt); +my $user = shift or die &usage; + +adminsuidsetup $user; + +my $now = time; #eventually take a time option like freeside-bill +my ($sec,$min,$hour,$mday,$mon,$year) = + (localtime($now) )[0,1,2,3,4,5]; +$mon++; +$year += 1900; + +foreach $cust_main ( qsearch('cust_main',{} ) ) { + + my ( $eyear, $emon, $eday ) = ( 2037, 12, 31 ); + if ( $cust_main->paydate =~ /^(\d{4})\-(\d{1,2})\-(\d{1,2})$/ + && $cust_main->payby eq 'BILL') { + ( $eyear, $emon, $eday ) = ( $1, $2, $3 ); + } + + if ( ( $opt{d} + && $cust_main->balance_date(time - $opt{d} * 86400) > 0 + && qsearchs( 'cust_pkg', { 'custnum' => $cust_main->custnum, + 'susp' => "" } ) ) + || ( $opt{e} + && $cust_main->payby eq 'BILL' + && ( $eyear < $year + || ( $eyear == $year && $emon < $mon ) ) ) + ) { + + unless ( $opt{q} ) { + print $cust_main->custnum, "\t", + $cust_main->last, "\t", $cust_main->first, "\t", + $cust_main->balance_date(time-$opt{d} * 86400); + } + + if ( $opt{p} && ! grep { $_ eq 'POST' } $cust_main->invoicing_list ) { + print "\n\tAdding postal invoicing" unless $opt{q}; + my @invoicing_list = $cust_main->invoicing_list; + push @invoicing_list, 'POST'; + $cust_main->invoicing_list(\@invoicing_list); + } + + if ( $opt{l} ) { + print "\n\tCharging late fee of \$$opt{l}" unless $opt{q}; + my $error = $cust_main->charge($opt{l}, 'Late fee'); + # comment or plandata with info so we don't redo the same late fee every + # day + } + + foreach $cust_pkg ( qsearch( 'cust_pkg', + { 'custnum' => $cust_main->custnum } ) ) { + + if ($opt{s}) { + print "\n\tSuspending pkgnum " . $cust_pkg->pkgnum unless $opt{q}; + $cust_pkg->suspend; + } + + if ($opt{c}) { + print "\n\tCancelling pkgnum " . $cust_pkg->pkgnum unless $opt{q}; + $cust_pkg->cancel; + } + + } + + if ( $opt{b} ) { + print "\n\tBilling" unless $opt{q}; + my $error = $cust_main->bill('time'=>$now); + warn "Error billing, customer #" . $cust_main->custnum . + ":" . $error if $error; + } + + if ( $opt{y} ) { + print "\n\tApplying outstanding payments and credits" unless $opt{q}; + $cust_main->apply_payments; + $cust_main->apply_credits; + } + + if ( $opt{o} ) { + print "\n\tCollecting" unless $opt{q}; + my $error = $cust_main->collect( + 'invoice_time' => $now, + 'batch_card' => $opt{i} ? 'no' : 'yes', + 'force_print' => 'yes', + ); + warn "Error collecting from customer #" . $cust_main->custnum. ":$error" + if $error; + } + + print "\n" unless $opt{q}; + + } + +} + +sub untaint_argv { + foreach $_ ( $[ .. $#ARGV ) { + $ARGV[$_] =~ /^([\w\-\/\.]*)$/ || die "Illegal arguement \"$ARGV[$_]\""; + $ARGV[$_]=$1; + } +} + +sub usage { + die "Usage:\n\n freeside-overdue [ -e ] [ -d days ] [ -q ] [ -p ] [ -l amount ] [ -s ] [ -c ] [ -b ] [ -y ] [ -o [ -i ] ] user\n"; +} + + +=head1 NAME + +freeside-overdue - Perform actions on overdue and/or expired accounts. + +=head1 SYNOPSIS + + freeside-overdue [ -e ] [ -d days ] [ -q ] [ -p ] [ -l amount ] [ -s ] [ -c ] [ -b ] [ -y ] [ -o [ -i ] ] user + +=head1 DESCRIPTION + +Performs actions on overdue and/or expired accounts. + +Selection options (at least one selection option is required): + + -d: Customers with a balance due on invoices older than the supplied number + of days. Requires an integer argument. + + -e: Customers with a billing expiration date in the past. + +Action options: + + -q: Be quiet (by default, selected accounts are printed). + + -p: Add postal invoicing to the relevant customers. + + -l: Add a charge of the given amount to the relevant customers. + + -s: Suspend accounts. + + -c: Cancel accounts. + + -b: Bill customers (create invoices) + + -y: Apply unapplied payments and credits + + -o: Collect from customers (charge cards, print invoices) + + -i: real-time billing (as opposed to batch billing). only relevant + for credit cards. + + user: From the mapsecrets file - see config.html from the base documentation + +=head1 CRONTAB + +Example crontab entries: + +# suspend expired accounts +20 4 * * * freeside-overdue -e -s user + +# quietly add postal invoicing to customers over 30 days past due +20 4 * * * freeside-overdue -d 30 -p -q user + +# suspend accounts and charge a $10.23 fee for customers over 60 days past due +20 4 * * * freeside-overdue -d 60 -s -l 10.23 user + +# cancel accounts over 90 days past due +20 4 * * * freeside-overdue -d 90 -c user + +=head1 ORIGINAL AUTHORS + +Original disable-overdue version by mw/kwh: Mark W.? and Kristian Hoffmann ? + +Ivan seems to be turning it into the "do-everything" CLI. + +=head1 BUGS + +Hell now that this is the do-everything CLI it should have --longoptions + +=cut + +1; + diff --git a/FS/bin/freeside-queued b/FS/bin/freeside-queued new file mode 100644 index 000000000..56475d059 --- /dev/null +++ b/FS/bin/freeside-queued @@ -0,0 +1,176 @@ +#!/usr/bin/perl -w + +use strict; +use vars qw( $log_file $sigterm $sigint ); +use subs qw( _die _logmsg ); +use Fcntl qw(:flock); +use POSIX qw(setsid); +use Date::Format; +use IO::File; +use FS::UID qw(adminsuidsetup forksuidsetup driver_name); +use FS::Record qw(qsearchs); +use FS::queue; + +# no autoloading just yet +use FS::cust_main; +use FS::svc_acct; +use Net::SSH 0.05; + +my $pid_file = '/var/run/freeside-queued.pid'; + +my $user = shift or die &usage; + +&daemonize; + +sub REAPER { my $pid = wait; $SIG{CHLD} = \&REAPER; } +$SIG{CHLD} = \&REAPER; + + $sigterm = 0; + $sigint = 0; +$SIG{INT} = sub { warn "SIGINT received; shutting down\n"; $sigint++; }; +$SIG{TERM} = sub { warn "SIGTERM received; shutting down\n"; $sigterm++; }; + +$> = $FS::UID::freeside_uid unless $>; +$< = $>; +$ENV{HOME} = (getpwuid($>))[7]; #for ssh +adminsuidsetup $user; + +$log_file = "/usr/local/etc/freeside/queuelog.". $FS::UID::datasrc; + +$SIG{__DIE__} = \&_die; +$SIG{__WARN__} = \&_logmsg; + +warn "freeside-queued starting\n"; + +while (1) { + + my $job = qsearchs( + 'queue', + { 'status' => 'new' }, + '', + driver_name =~ /^mysql$/i + ? 'ORDER BY jobnum LIMIT 1 FOR UPDATE' + : 'ORDER BY jobnum FOR UPDATE LIMIT 1' + ) or do { + sleep 5; + next; + }; + + my %hash = $job->hash; + $hash{'status'} = 'locked'; + my $ljob = new FS::queue ( \%hash ); + my $error = $ljob->replace($job); + die $error if $error; + + my @args = $ljob->args; + + # number of children limit? + defined( my $pid = fork ) or do { + warn "WARNING: can't fork: $!\n"; + my %hash = $job->hash; + $hash{'status'} = 'failed'; + $hash{'statustext'} = "[freeside-queued] can't fork: $!"; + my $ljob = new FS::queue ( \%hash ); + my $error = $ljob->replace($job); + die $error if $error; + }; + + unless ( $pid ) { #kid time + + #get new db handles + $FS::UID::dbh->{InactiveDestroy} = 1; + $FS::svc_acct::icradius_dbh->{InactiveDestroy} = 1 + if $FS::svc_acct::icradius_dbh; + forksuidsetup($user); + + my $eval = "&". $ljob->job. '(@args);'; + warn "running $eval"; + eval $eval; + if ( $@ ) { + warn "job $eval failed"; + my %hash = $ljob->hash; + $hash{'status'} = 'failed'; + $hash{'statustext'} = $@; + my $fjob = new FS::queue( \%hash ); + my $error = $fjob->replace($ljob); + die $error if $error; + } else { + $ljob->delete; + } + + exit; + #end-of-kid + } + +} continue { + if ( $sigterm ) { + warn "received TERM signal; exiting\n"; + exit; + } + if ( $sigint ) { + warn "received INT signal; exiting\n"; + exit; + } +} + +sub usage { + die "Usage:\n\n freeside-queued user\n"; +} + +sub _die { + my $msg = shift; + unlink $pid_file if -e $pid_file; + _logmsg($msg); +} + +sub _logmsg { + chomp( my $msg = shift ); + my $log = new IO::File ">>$log_file"; + flock($log, LOCK_EX); + seek($log, 0, 2); + print $log "[". time2str("%a %b %e %T %Y",time). "] [$$] $msg\n"; + flock($log, LOCK_UN); + close $log; +} + +sub daemonize { + + chdir "/" or die "Can't chdir to /: $!"; + open STDIN, '/dev/null' or die "Can't read /dev/null: $!"; + defined(my $pid = fork) or die "Can't fork: $!"; + if ( $pid ) { + print "freeside-queued started with pid $pid\n"; #logging to $log_file\n"; + exit unless $pid_file; + my $pidfh = new IO::File ">$pid_file" or exit; + print $pidfh "$pid\n"; + exit; + } + open STDOUT, '>/dev/null' + or die "Can't write to /dev/null: $!"; + setsid or die "Can't start a new session: $!"; + open STDERR, '>&STDOUT' or die "Can't dup stdout: $!"; + +} + +=head1 NAME + +freeside-queued - Job queue daemon + +=head1 SYNOPSIS + + freeside-queued user + +=head1 DESCRIPTION + +Job queue daemon. Should be running at all times. + +user: from the mapsecrets file - see config.html from the base documentation + +=head1 VERSION + +=head1 BUGS + +=head1 SEE ALSO + +=cut + diff --git a/FS/bin/freeside-receivables-report b/FS/bin/freeside-receivables-report new file mode 100755 index 000000000..cef652bfe --- /dev/null +++ b/FS/bin/freeside-receivables-report @@ -0,0 +1,218 @@ +#!/usr/bin/perl -Tw + +use strict; +use Date::Parse; +use Time::Local; +use Getopt::Std; +use Text::Template; +use FS::Conf; +use FS::UID qw(adminsuidsetup); +use FS::Record qw(qsearch); +use FS::cust_main; + +# 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_m $opt_e $opt_t $report_lines $report_template @buf); +getopts("vpmet:"); #switches + +#we're at now now (and later). +my($_date)= $^T; + +# Get the current month +my ($sec,$min,$hour,$mday,$mon,$year) = + (localtime($_date) )[0,1,2,3,4,5]; +$mon++; +$year += 1900; + +# 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 @report_template = $conf->config('report_template') + or die "cannot load config file report_template"; +$report_lines = 0; + foreach ( grep /report_lines\(\d+\)/, @report_template ) { #kludgy :/ + /report_lines\((\d+)\)/; + $report_lines += $1; +} +die "no report_lines() functions in template?" unless $report_lines; +$report_template = new Text::Template ( + TYPE => 'ARRAY', + SOURCE => [ map "$_\n", @report_template ], +) or die "can't create new Text::Template object: $Text::Template::ERROR"; + + +my(@customers)=qsearch('cust_main',{}); +if (scalar(@customers) == 0) +{ + exit 1; +} + +# Open print and email pipes +# $lpr and opt_p for printing +# $email and opt_m for email + +if ($lpr && $opt_p) +{ + open(LPR, "|$lpr"); +} + +if ($email && $opt_m) +{ + open (MAIL, "|$mail_program"); + print MAIL <<END +To: $email +From: Account Processor +Subject: Receivables + + +END +} + +my $total = 0; + + +# Now I can start looping +foreach my $customer (@customers) +{ + my $custnum = $customer->getfield('custnum'); + my $first = $customer->getfield('first'); + my $last = $customer->getfield('last'); + my $company = $customer->getfield('company'); + my $daytime = $customer->getfield('daytime'); + my $balance = $customer->balance; + + + if ($balance != 0) { + $total += $balance; + push @buf, sprintf(qq{%5d %-32.32s %12s %9.2f}, + $custnum, + $first . " " . $last . " " . $company, + $daytime, + $balance); + + } + +} + +push @buf, ('', sprintf(qq{%61s}, "========="), sprintf(qq{%61.2f}, $total)); + +sub FS::receivables_report::_template::report_lines { + my $lines = shift; + map { + scalar(@buf) ? shift @buf : '' ; + } + ( 1 .. $lines ); +} + +$FS::receivables_report::_template::title = " R E C E I V A B L E S "; +$FS::receivables_report::_template::title = $opt_t if $opt_t; +$FS::receivables_report::_template::page = 1; +$FS::receivables_report::_template::date = $_date; +$FS::receivables_report::_template::date = $_date; +$FS::receivables_report::_template::total_pages = + int( scalar(@buf) / $report_lines); +$FS::receivables_report::_template::total_pages++ if scalar(@buf) % $report_lines; + +my @report; +while (@buf) { + push @report, split("\n", + $report_template->fill_in( PACKAGE => 'FS::receivables_report::_template' ) + ); + $FS::receivables_report::_template::page++; +} + +if ($opt_v) { + print map "$_\n", @report; +} +if($lpr && $opt_p) +{ + print LPR map "$_\n", @report; + print LPR "\f" if $opt_e; + close LPR || die "Could not close printer: $lpr\n"; +} +if($email && $opt_m) +{ + print MAIL map "$_\n", @report; + close MAIL || die "Could not close printer: $email\n"; +} + + +# subroutines + +sub untaint_argv { + foreach $_ ( $[ .. $#ARGV ) { #untaint @ARGV + $ARGV[$_] =~ /^([\w\-\/ ]*)$/ || die "Illegal argument \"$ARGV[$_]\""; + $ARGV[$_]=$1; + } +} + +sub usage { + die "Usage:\n\n freeside-receivables-report [-v] [-p] [-e] user\n"; +} + +=head1 NAME + +freeside-receivables-report - Prints or emails outstanding receivables. + +=head1 SYNOPSIS + + freeside-receivables-report [-v] [-p] [-m] [-e] [-t "title"] user + +=head1 DESCRIPTION + +Prints or emails outstanding receivables + +-v: Verbose - Prints records to STDOUT. + +-p: Print to printer lpr as found in the conf directory. + +-m: Mail output to user found in the Conf email file. + +-e: Print a final form feed to the printer. + +-t: supply a title for the top of each page. + +user: From the mapsecrets file - see config.html from the base documentation + +=head1 VERSION + +$Id: freeside-receivables-report,v 1.1 2002-02-22 23:18:32 jeff 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-receivables-report,v $ +Revision 1.1 2002-02-22 23:18:32 jeff +add some reporting features + +Revision 1.1 2000/09/20 19:25:19 jeff +local modifications + +Revision 1.1 2000/05/13 21:57:56 ivan +add print_batch script from Joel Griffiths + + +=cut + + diff --git a/FS/bin/freeside-setinvoice b/FS/bin/freeside-setinvoice new file mode 100644 index 000000000..708e2fa30 --- /dev/null +++ b/FS/bin/freeside-setinvoice @@ -0,0 +1,42 @@ +#!/usr/bin/perl + +use strict; +use FS::UID qw(adminsuidsetup); +use FS::Conf; +use FS::Record qw(qsearch qsearchs); +use FS::cust_main; +use FS::svc_acct; + +&untaint_argv; #what it sounds like (eww) +my $user = shift or die &usage; + +adminsuidsetup $user; + +foreach my $cust_main ( + grep { ! scalar($_->invoicing_list) } + qsearch( 'cust_main', {} ) +) { + my @dest; + my @cust_pkg = $cust_main->ncancelled_pkgs; + foreach my $cust_pkg ( @cust_pkg ) { + foreach my $cust_svc ( $cust_pkg->cust_svc ) { + my $svc_acct = qsearchs( 'svc_acct', { 'svcnum' => $cust_svc->svcnum } ); + push @dest, $svc_acct->svcnum if $svc_acct; + } + } + push @dest, 'POST' unless @dest; + $cust_main->invoicing_list(\@dest); +} + +sub untaint_argv { + foreach $_ ( $[ .. $#ARGV ) { #untaint @ARGV + $ARGV[$_] =~ /^(.*)$/ || die "Illegal arguement \"$ARGV[$_]\""; + $ARGV[$_]=$1; + } +} + +sub usage { + die "Usage:\n\n freeside-setinvoice user\n"; +} + + diff --git a/FS/bin/freeside-tax-report b/FS/bin/freeside-tax-report new file mode 100755 index 000000000..334c4107b --- /dev/null +++ b/FS/bin/freeside-tax-report @@ -0,0 +1,270 @@ +#!/usr/bin/perl -Tw + +use strict; +use Date::Parse; +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; + +# 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_d $opt_s); +getopts("vped:s:"); #switches + +#we're at now now (and later). +my($_enddate)= $main::opt_d ? str2time($main::opt_d) : $^T; +my($_startdate)= $main::opt_s ? str2time($main::opt_s) : $^T; + +# Get the current month +my ($ssec,$smin,$shour,$smday,$smon,$syear) = + (localtime($_startdate) )[0,1,2,3,4,5]; +$smon++; +$syear -= 100 if $syear >= 100; +$syear = "0" . $syear if $syear < 10; + +# Get the current month +my ($esec,$emin,$ehour,$emday,$emon,$eyear) = + (localtime($_enddate) )[0,1,2,3,4,5]; +$emon++; +$eyear -= 100 if $eyear >= 100; +$eyear = "0" . $eyear if $eyear < 10; + +# 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(@cust_bills)=qsearch('cust_bill',{}); +if (scalar(@cust_bills) == 0) +{ + exit 1; +} + +if ($main::opt_v) +{ + print qq~ S A L E S T A X E S I N V O I C E D for period beginning: $smon/$smday/$syear and ending $emon/$emday/$eyear\n\n~; +} + +# 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~ S A L E S T A X E S I N V O I C E D for period beginning: $smon/$smday/$syear and ending $emon/$emday/$eyear\n\n~; +} + +if ($email && $main::opt_e) +{ + open (MAIL, "|$mail_program"); + print MAIL <<END +To: $email +From: Account Processor +Subject: Sales Taxes Invoiced + + +S A L E S T A X E S I N V O I C E D for period beginning: $smon/$smday/$syear and ending $emon/$emday/$eyear + +END +} + +my $compped = 0; +my $compped_tax = 0; +my $other = 0; +my $other_tax = 0; +my $total = 0; +my $taxed = 0; +my $untaxed = 0; +my $total_tax = 0; + +# Now I can start looping +foreach my $cust_bill (@cust_bills) +{ + my $_date = $cust_bill->getfield('_date'); + my $invnum = $cust_bill->getfield('invnum'); + my $charged = $cust_bill->getfield('charged'); + + + if ($_date >= $_startdate && $_date <= $_enddate) { + $total += $charged; + + # The following lines were used to produce rather verbose reports + #my ($sec,$min,$hour,$mday,$mon,$year) = + # (localtime($_date) )[0,1,2,3,4,5]; + #$mon++; + #$year -= 100 if $year >= 100; + #$year = "0" . $year if $year < 10; + + my $invoice_amt =0; + my $invoice_tax =0; + my $invoice_compped =0; + my(@cust_bill_pkgs)= $cust_bill->cust_bill_pkg; + foreach my $cust_bill_pkg (@cust_bill_pkgs) { + + my $recur = $cust_bill_pkg->getfield('recur'); + my $setup = $cust_bill_pkg->getfield('setup'); + my $pkgnum = $cust_bill_pkg->getfield('pkgnum'); + + if ($pkgnum == 0) { + # The following line was used to produce rather verbose reports + # printf(MAIL qq{\n%10s%15s%14.2f}, "$mon/$mday/$year", "Tax $invnum", $recur+$setup); + $invoice_tax += $recur; + $invoice_tax += $setup; + } else { + # The following line was used to produce rather verbose reports + # printf(MAIL qq{\n%10s%15s%14.2f}, "$mon/$mday/$year", "Inv $invnum", $recur+$setup); + $invoice_amt += $recur; + $invoice_amt += $setup; + } + + } + + my(@cust_bill_pays)= $cust_bill->cust_bill_pay; + foreach my $cust_bill_pay (@cust_bill_pays) { + my $payby = $cust_bill_pay->cust_pay->payby; + my $paid = $cust_bill_pay->getfield('amount'); + if ($payby =~ 'COMP') { + $invoice_compped += $paid; + } + } + + if (abs($invoice_compped - ($invoice_amt + $invoice_tax)) < 0.0001){ + $compped += $invoice_amt; + $compped_tax += $invoice_tax; + } elsif ($invoice_compped > 0) { + printf(qq{\nInvoice %10d has inexpliciable complimentary payments of %14.9f\n}, $invnum, $invoice_compped); + $other += $invoice_amt; + $other_tax += $invoice_tax; + } elsif ($invoice_tax > 0) { + $total_tax += $invoice_tax; + $taxed += $invoice_amt; + } else { + $untaxed += $invoice_amt; + } + + } + +} + +if ($main::opt_v) { + printf(qq{\n\n%25s%14.2f\n}, "Complimentary", $compped); + printf(qq{%25s%14.2f\n}, "Complimentary Tax", $compped_tax); + printf(qq{%25s%14.2f\n}, "Other", $other); + printf(qq{%25s%14.2f\n}, "Other Tax", $other_tax); + printf(qq{%25s%14.2f\n}, "Untaxed", $untaxed); + printf(qq{%25s%14.2f\n}, "Taxed", $taxed); + printf(qq{%25s%14.2f\n}, "Tax", $total_tax); + printf(qq{\n%39s\n%39.2f\n}, "=========", $total); +} + +# Now I need to close LPR and EMAIL if they were open +if($lpr && $main::opt_p) +{ + printf(LPR qq{\n\n%25s%14.2f\n}, "Complimentary", $compped); + printf(LPR qq{%25s%14.2f\n}, "Complimentary Tax", $compped_tax); + printf(LPR qq{%25s%14.2f\n}, "Other", $other); + printf(LPR qq{%25s%14.2f\n}, "Other Tax", $other_tax); + printf(LPR qq{%25s%14.2f\n}, "Untaxed", $untaxed); + printf(LPR qq{%25s%14.2f\n}, "Taxed", $taxed); + printf(LPR qq{%25s%14.2f\n}, "Tax", $total_tax); + printf(LPR qq{\n%39s\n%39.2f\n}, "=========", $total); + close LPR || die "Could not close printer: $lpr\n"; +} +if($email && $main::opt_e) +{ + printf(MAIL qq{\n\n%25s%14.2f\n}, "Complimentary", $compped); + printf(MAIL qq{%25s%14.2f\n}, "Complimentary Tax", $compped_tax); + printf(MAIL qq{%25s%14.2f\n}, "Other", $other); + printf(MAIL qq{%25s%14.2f\n}, "Other Tax", $other_tax); + printf(MAIL qq{%25s%14.2f\n}, "Untaxed", $untaxed); + printf(MAIL qq{%25s%14.2f\n}, "Taxed", $taxed); + printf(MAIL qq{%25s%14.2f\n}, "Tax", $total_tax); + printf(MAIL qq{\n%39s\n%39.2f\n}, "=========", $total); + close MAIL || die "Could not close printer: $email\n"; +} + + +# subroutines +sub untaint_argv { + foreach $_ ( $[ .. $#ARGV ) { #untaint @ARGV + $ARGV[$_] =~ /^([\w\-\/ :]*)$/ || die "Illegal argument \"$ARGV[$_]\""; + $ARGV[$_]=$1; + } +} + +sub usage { + die "Usage:\n\n freeside-tax-report [-v] [-p] [-e] user\n"; +} + +=head1 NAME + +freeside-tax-report - Prints or emails sales taxes invoiced in a given period. + +=head1 SYNOPSIS + + freeside-tax-report [-v] [-p] [-e] user + +=head1 DESCRIPTION + +Prints or emails sales taxes invoiced in a given period. + +-v: Verbose - Prints records to STDOUT. + +-p: Print to printer lpr as found in the conf directory. + +-e: Email output to user found in the Conf email file. + +user: From the mapsecrets file - see config.html from the base documentation + +=head1 VERSION + +$Id: freeside-tax-report,v 1.1 2002-02-22 23:18:32 jeff 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-tax-report,v $ +Revision 1.1 2002-02-22 23:18:32 jeff +add some reporting features + +Revision 1.3 2002/02/19 14:24:53 jeff +might be functional now + +Revision 1.2 2001/08/20 18:31:49 jeff +before-merge-to-freeside_1_4_0-pre1 + +Revision 1.1 2000/09/20 19:25:19 jeff +local modifications + +Revision 1.1 2000/05/13 21:57:56 ivan +add print_batch script from Joel Griffiths + + +=cut + + diff --git a/FS/t/CGI.t b/FS/t/CGI.t new file mode 100644 index 000000000..1b4e238b6 --- /dev/null +++ b/FS/t/CGI.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::CGI; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/Conf.t b/FS/t/Conf.t new file mode 100644 index 000000000..a9f7653b3 --- /dev/null +++ b/FS/t/Conf.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::Conf; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/ConfItem.t b/FS/t/ConfItem.t new file mode 100644 index 000000000..c7932d7e3 --- /dev/null +++ b/FS/t/ConfItem.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::ConfItem; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/Record.t b/FS/t/Record.t new file mode 100644 index 000000000..00de1eda3 --- /dev/null +++ b/FS/t/Record.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::Record; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/SearchCache.t b/FS/t/SearchCache.t new file mode 100644 index 000000000..3c26f3528 --- /dev/null +++ b/FS/t/SearchCache.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::SearchCache; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/UID.t b/FS/t/UID.t new file mode 100644 index 000000000..9f7da4e89 --- /dev/null +++ b/FS/t/UID.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::UID; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/agent.t b/FS/t/agent.t new file mode 100644 index 000000000..769cce254 --- /dev/null +++ b/FS/t/agent.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::agent; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/agent_type.t b/FS/t/agent_type.t new file mode 100644 index 000000000..99c66a151 --- /dev/null +++ b/FS/t/agent_type.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::agent_type; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_bill.t b/FS/t/cust_bill.t new file mode 100644 index 000000000..b43f08ee2 --- /dev/null +++ b/FS/t/cust_bill.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_bill; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_bill_event.t b/FS/t/cust_bill_event.t new file mode 100644 index 000000000..0e2ca3e24 --- /dev/null +++ b/FS/t/cust_bill_event.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_bill_event; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_bill_pay.t b/FS/t/cust_bill_pay.t new file mode 100644 index 000000000..001eed01e --- /dev/null +++ b/FS/t/cust_bill_pay.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_bill_pay; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_bill_pkg.t b/FS/t/cust_bill_pkg.t new file mode 100644 index 000000000..0e45bdb0c --- /dev/null +++ b/FS/t/cust_bill_pkg.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_bill_pkg; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_credit.t b/FS/t/cust_credit.t new file mode 100644 index 000000000..cddf75cff --- /dev/null +++ b/FS/t/cust_credit.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_credit; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_credit_bill.t b/FS/t/cust_credit_bill.t new file mode 100644 index 000000000..0ef54c3f1 --- /dev/null +++ b/FS/t/cust_credit_bill.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_credit_bill; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_credit_refund.t b/FS/t/cust_credit_refund.t new file mode 100644 index 000000000..6b2b599f3 --- /dev/null +++ b/FS/t/cust_credit_refund.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_credit_refund; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_main.t b/FS/t/cust_main.t new file mode 100644 index 000000000..b0ffbdb32 --- /dev/null +++ b/FS/t/cust_main.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_main; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_main_county.t b/FS/t/cust_main_county.t new file mode 100644 index 000000000..dd6119911 --- /dev/null +++ b/FS/t/cust_main_county.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_main_county; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_main_invoice.t b/FS/t/cust_main_invoice.t new file mode 100644 index 000000000..9661620e0 --- /dev/null +++ b/FS/t/cust_main_invoice.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_main_invoice; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_pay.t b/FS/t/cust_pay.t new file mode 100644 index 000000000..f6d0b7571 --- /dev/null +++ b/FS/t/cust_pay.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_pay; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_pay_batch.t b/FS/t/cust_pay_batch.t new file mode 100644 index 000000000..02b572c15 --- /dev/null +++ b/FS/t/cust_pay_batch.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_pay_batch; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_pkg.t b/FS/t/cust_pkg.t new file mode 100644 index 000000000..c6a686061 --- /dev/null +++ b/FS/t/cust_pkg.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_pkg; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_refund.t b/FS/t/cust_refund.t new file mode 100644 index 000000000..91583da28 --- /dev/null +++ b/FS/t/cust_refund.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_refund; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_svc.t b/FS/t/cust_svc.t new file mode 100644 index 000000000..267d731db --- /dev/null +++ b/FS/t/cust_svc.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_svc; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/domain_record.t b/FS/t/domain_record.t new file mode 100644 index 000000000..794518ccf --- /dev/null +++ b/FS/t/domain_record.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::domain_record; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/nas.t b/FS/t/nas.t new file mode 100644 index 000000000..6f8ae36d2 --- /dev/null +++ b/FS/t/nas.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::nas; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/part_bill_event.t b/FS/t/part_bill_event.t new file mode 100644 index 000000000..5626a9f97 --- /dev/null +++ b/FS/t/part_bill_event.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::part_bill_event; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/part_pkg.t b/FS/t/part_pkg.t new file mode 100644 index 000000000..fd96073f9 --- /dev/null +++ b/FS/t/part_pkg.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::part_pkg; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/part_pop_local.t b/FS/t/part_pop_local.t new file mode 100644 index 000000000..4e4ad17f5 --- /dev/null +++ b/FS/t/part_pop_local.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::part_pop_local; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/part_referral.t b/FS/t/part_referral.t new file mode 100644 index 000000000..d20b97930 --- /dev/null +++ b/FS/t/part_referral.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::part_referral; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/part_svc.t b/FS/t/part_svc.t new file mode 100644 index 000000000..bdb2a7aca --- /dev/null +++ b/FS/t/part_svc.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::part_svc; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/part_svc_column.t b/FS/t/part_svc_column.t new file mode 100644 index 000000000..467025c1e --- /dev/null +++ b/FS/t/part_svc_column.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::part_svc_column; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/pkg_svc.t b/FS/t/pkg_svc.t new file mode 100644 index 000000000..77d34295a --- /dev/null +++ b/FS/t/pkg_svc.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::pkg_svc; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/port.t b/FS/t/port.t new file mode 100644 index 000000000..46377aaf9 --- /dev/null +++ b/FS/t/port.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::port; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/prepay_credit.t b/FS/t/prepay_credit.t new file mode 100644 index 000000000..e7626bdf1 --- /dev/null +++ b/FS/t/prepay_credit.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::prepay_credit; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/queue.t b/FS/t/queue.t new file mode 100644 index 000000000..43e33730e --- /dev/null +++ b/FS/t/queue.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::queue; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/queue_arg.t b/FS/t/queue_arg.t new file mode 100644 index 000000000..cf3f91dfe --- /dev/null +++ b/FS/t/queue_arg.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::queue_arg; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/raddb.t b/FS/t/raddb.t new file mode 100644 index 000000000..ac28d0798 --- /dev/null +++ b/FS/t/raddb.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::raddb; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/session.t b/FS/t/session.t new file mode 100644 index 000000000..c4b714ea4 --- /dev/null +++ b/FS/t/session.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::session; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/svc_Common.t b/FS/t/svc_Common.t new file mode 100644 index 000000000..ed49e1e49 --- /dev/null +++ b/FS/t/svc_Common.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::svc_Common; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/svc_acct.t b/FS/t/svc_acct.t new file mode 100644 index 000000000..9ca78c9d1 --- /dev/null +++ b/FS/t/svc_acct.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::svc_acct; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/svc_acct_pop.t b/FS/t/svc_acct_pop.t new file mode 100644 index 000000000..e612c40af --- /dev/null +++ b/FS/t/svc_acct_pop.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::svc_acct_pop; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/svc_acct_sm.t b/FS/t/svc_acct_sm.t new file mode 100644 index 000000000..1082f2cdb --- /dev/null +++ b/FS/t/svc_acct_sm.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::svc_acct_sm; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/svc_domain.t b/FS/t/svc_domain.t new file mode 100644 index 000000000..4d91898ac --- /dev/null +++ b/FS/t/svc_domain.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::svc_domain; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/svc_forward.t b/FS/t/svc_forward.t new file mode 100644 index 000000000..d653d34ef --- /dev/null +++ b/FS/t/svc_forward.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::svc_forward; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/svc_www.t b/FS/t/svc_www.t new file mode 100644 index 000000000..eb4e83fbc --- /dev/null +++ b/FS/t/svc_www.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::svc_www; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/type_pkgs.t b/FS/t/type_pkgs.t new file mode 100644 index 000000000..98401805c --- /dev/null +++ b/FS/t/type_pkgs.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::type_pkgs; +$loaded=1; +print "ok 1\n"; |