diff options
Diffstat (limited to 'FS')
187 files changed, 18265 insertions, 3031 deletions
@@ -111,6 +111,8 @@ L<FS::cust_svc> - Service class L<FS::cust_pkg> - Customer package class +L<FS::cust_pkg_option> - Customer package option class + L<FS::cust_main> - Customer class L<FS::cust_main_invoice> - Invoice destination @@ -142,7 +144,9 @@ L<FS::cust_credit_bill> - Credit application to invoice class L<FS::cust_pay_refund> - Refund application to payment class -L<FS::cust_pay_batch> - Credit card transaction queue class +L<FS::pay_batch> - Credit card transaction queue class + +L<FS::cust_pay_batch> - Credit card transaction member queue class L<FS::prepay_credit> - Prepaid "calling card" credit class. diff --git a/FS/FS/AccessRight.pm b/FS/FS/AccessRight.pm new file mode 100644 index 000000000..5194bd4d9 --- /dev/null +++ b/FS/FS/AccessRight.pm @@ -0,0 +1,202 @@ +package FS::AccessRight; + +use strict; +use vars qw(@rights); # %rights); +use Tie::IxHash; + +=head1 NAME + +FS::AccessRight - Access control rights. + +=head1 SYNOPSIS + + use FS::AccessRight; + +=head1 DESCRIPTION + +Access control rights - Permission to perform specific actions that can be +assigned to users and/or groups. + +=cut + +#@rights = ( +# 'Reports' => [ +# '_desc' => 'Access to high-level reporting', +# ], +# 'Configuration' => [ +# '_desc' => 'Access to configuration', +# +# 'Settings' => {}, +# +# 'agent' => [ +# '_desc' => 'Master access to reseller configuration', +# 'agent_type' => {}, +# 'agent' => {}, +# ], +# +# 'export_svc_pkg' => [ +# '_desc' => 'Access to export, service and package configuration', +# 'part_export' => {}, +# 'part_svc' => {}, +# 'part_pkg' => {}, +# 'pkg_class' => {}, +# ], +# +# 'billing' => [ +# '_desc' => 'Access to billing configuration', +# 'payment_gateway' => {}, +# 'part_bill_event' => {}, +# 'prepay_credit' => {}, +# 'rate' => {}, +# 'cust_main_county' => {}, +# ], +# +# 'dialup' => [ +# '_desc' => 'Access to dialup configuraiton', +# 'svc_acct_pop' => {}, +# ], +# +# 'broadband' => [ +# '_desc' => 'Access to broadband configuration', +# 'router' => {}, +# 'addr_block' => {}, +# ], +# +# 'misc' => [ +# 'part_referral' => {}, +# 'part_virtual_field' => {}, +# 'msgcat' => {}, +# 'inventory_class' => {}, +# ], +# +# }, +# +#); +# +##turn it into a more hash-like structure, but ordered via IxHash + +#well, this is what we have for now. could be ordered better, could be lots of +# things better, but this ACL system does 99% of what folks need and the UI +# isn't *that* bad +# +# okay, well it *really* needs some catgorization in the UI. badly. +@rights = ( + +## +# basic customer rights +## + 'New customer', + 'View customer', + #'View Customer | View tickets', + 'Edit customer', + 'Cancel customer', + 'Complimentary customer', #aka users-allow_comp + 'Delete customer', #aka. deletecustomers #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. + 'Add customer note', #NEW + 'Edit customer note', #NEW + +### +# customer package rights +### + 'View customer packages', #NEW + 'Order customer package', + 'One-time charge', + 'Change customer package', + 'Bulk change customer packages', + 'Edit customer package dates', + 'Customize customer package', + 'Suspend customer package', + 'Unsuspend customer package', + 'Cancel customer package immediately', + 'Cancel customer package later', + 'Add on-the-fly cancel reason', #NEW + 'Add on-the-fly suspend reason', #NEW + +### +# customer service rights +### + 'Edit usage', #NEW + 'View customer services', #NEW + 'Provision customer service', + 'Recharge customer service', #NEW + 'Unprovision customer service', + + 'View/link unlinked services', #not agent-virtualizable without more work + +### +# customer invoice/financial info rights +### + 'View invoices', + 'View customer tax exemptions', #yow + 'View customer batched payments', #NEW + +### +# customer payment rights +### + 'Post payment', + 'Post payment batch', + 'Unapply payment', #aka. unapplypayments Enable "unapplication" of unclosed payments. + 'Process payment', + 'Refund payment', + + 'Delete payment', #aka. deletepayments - Enable deletion of unclosed payments. Be very careful! Only delete payments that were data-entry errors, not adjustments. Optionally specify one or more comma-separated email addresses to be notified when a payment is deleted. + + 'Delete refund', #NEW + +### +# customer credit rights +### + 'Post credit', + #'Apply credit', + 'Unapply credit', #aka unapplycredits Enable "unapplication" of unclosed credits. + 'Delete credit', #aka. deletecredits Enable deletion of unclosed credits. Be very careful! Only delete credits that were data-entry errors, not adjustments. Optionally specify one or more comma-separated email addresses to be notified when a credit is deleted. + +### +# customer voiding rights.. +### + 'Credit card void', #aka. cc-void #Enable local-only voiding of echeck payments in addition to refunds against the payment gateway + 'Echeck void', #aka. echeck-void #Enable local-only voiding of echeck payments in addition to refunds against the payment gateway + 'Regular void', + 'Unvoid', #aka. unvoid #Enable unvoiding of voided payments + +### +# report/listing rights... +### + 'List customers', + 'List zip codes', #NEW + 'List invoices', + 'List packages', + 'List services', + + 'List rating data', # 'Usage reports', + 'Billing event reports', + 'Financial reports', + +### +# misc rights +### + 'Job queue', # these are not currently agent-virtualized + 'Process batches', # NEW + 'Reprocess batches', # NEW + 'Import', # + 'Export', # + +### +# misc misc rights +### + 'Raw SQL', #NEW + +### +# setup/config rights +### + 'Edit advertising sources', + 'Edit global advertising sources', + + 'Configuration', #most of the rest of the configuraiton is not + # agent-virtualized +); + +sub rights { + @rights; +} + diff --git a/FS/FS/CGI.pm b/FS/FS/CGI.pm index 9dc635ad2..4c2693db8 100644 --- a/FS/FS/CGI.pm +++ b/FS/FS/CGI.pm @@ -9,7 +9,7 @@ use URI::URL; use FS::UID; @ISA = qw(Exporter); -@EXPORT_OK = qw(header menubar idiot eidiot popurl table itable ntable +@EXPORT_OK = qw(header menubar idiot eidiot popurl rooturl table itable ntable small_custview myexit http_header); =head1 NAME @@ -62,9 +62,9 @@ sub header { </HEAD> <BODY BGCOLOR="#e8e8e8"$etc> <FONT SIZE=6> - $title + <CENTER>$title</CENTER> </FONT> - <BR><BR> + <BR><!--<BR>--> END $x .= $menubar. "<BR><BR>" if $menubar; $x; @@ -79,14 +79,7 @@ Sets an http header. sub http_header { my ( $header, $value ) = @_; if (exists $ENV{MOD_PERL}) { - if ( defined $main::Response - && $main::Response->isa('Apache::ASP::Response') ) { #Apache::ASP - if ( $header =~ /^Content-Type$/ ) { - $main::Response->{ContentType} = $value; - } else { - $main::Response->AddHeader( $header => $value ); - } - } elsif ( defined $HTML::Mason::Commands::r ) { #Mason + if ( defined $HTML::Mason::Commands::r ) { #Mason ## is this the correct pacakge for $r ??? for 1.0x and 1.1x ? if ( $header =~ /^Content-Type$/ ) { $HTML::Mason::Commands::r->content_type($value); @@ -115,6 +108,7 @@ sub menubar { #$menubar=menubar('Main Menu', '../', 'Item', 'url', ... ); my($item,$url,@html); while (@_) { ($item,$url)=splice(@_,0,2); + next if $item =~ /^\s*Main\s+Menu\s*$/i; push @html, qq!<A HREF="$url">$item</A>!; } join(' | ',@html); @@ -185,12 +179,7 @@ If running under mod_perl, calles Apache::exit, otherwise, calls exit. 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 + if ( 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)"; @@ -225,6 +214,40 @@ sub popurl { $x; } +=item rooturl + +=cut + +sub rooturl { + # better to start with the client-provided URL + my $cgi = &FS::UID::cgi; + my $url_string = $cgi->isa('Apache') ? $cgi->uri : $cgi->url; + $url_string =~ s/\?.*//; + + #even though this is kludgy + $url_string =~ s{ / index\.html /? $ } + {/}x; + $url_string =~ + s{ + / + (browse|config|docs|edit|graph|misc|search|view|pref|rt|elements) + / + (process/)? + ([\w\-\.\/]+) + $ + } + {}x; + + #elements because of progress-popup.html... + #XXX remove anything from elements that is called directly & prevent + #those pages from being served up + + $url_string .= '/' unless $url_string =~ /\/$/; + + $url_string; + +} + =item table Returns HTML tag for beginning a table. @@ -277,7 +300,7 @@ sub ntable { } -=item small_custview CUSTNUM || CUST_MAIN_OBJECT, COUNTRYDEFAULT, NOBALANCE_FLAG +=item small_custview CUSTNUM || CUST_MAIN_OBJECT, COUNTRYDEFAULT, NOBALANCE_FLAG, URL Sheesh. I should just switch to Mason. @@ -290,12 +313,18 @@ sub small_custview { my $arg = shift; my $countrydefault = shift || 'US'; my $nobalance = shift; + my $url = shift; my $cust_main = ref($arg) ? $arg : qsearchs('cust_main', { 'custnum' => $arg } ) or die "unknown custnum $arg"; - my $html = 'Customer #<B>'. $cust_main->custnum. '</B></A>'. + my $html; + + $html = qq!View <A HREF="$url?! . $cust_main->custnum . '">' + if $url; + + $html .= 'Customer #<B>'. $cust_main->custnum. '</B></A>'. ' - <B><FONT COLOR="'. $cust_main->statuscolor. '">'. ucfirst($cust_main->status). '</FONT></B>'. ntable('#e8e8e8'). '<TR><TD VALIGN="top">'. ntable("#cccccc",2). diff --git a/FS/FS/ClientAPI/MyAccount.pm b/FS/FS/ClientAPI/MyAccount.pm index 4b67f53af..bade103f2 100644 --- a/FS/FS/ClientAPI/MyAccount.pm +++ b/FS/FS/ClientAPI/MyAccount.pm @@ -8,9 +8,11 @@ use Date::Format; use Business::CreditCard; use Time::Duration; use FS::CGI qw(small_custview); #doh +use FS::UI::Web; use FS::Conf; use FS::Record qw(qsearch qsearchs); use FS::Msgcat qw(gettext); +use FS::Misc qw(card_types); use FS::ClientAPI_SessionCache; use FS::svc_acct; use FS::svc_domain; @@ -20,6 +22,15 @@ use FS::cust_main; use FS::cust_bill; use FS::cust_main_county; use FS::cust_pkg; +use HTML::Entities; + +#false laziness with FS::cust_main +BEGIN { + eval "use Time::Local;"; + die "Time::Local minimum version 1.05 required with Perl versions before 5.6" + if $] < 5.006 && !defined($Time::Local::VERSION); + eval "use Time::Local qw(timelocal_nocheck);"; +} use vars qw( @cust_main_editable_fields ); @cust_main_editable_fields = qw( @@ -127,7 +138,7 @@ sub customer_info { } if ( $cust_main->payby =~ /^(CARD|DCRD)$/ ) { - $return{payinfo} = $cust_main->payinfo_masked; + $return{payinfo} = $cust_main->paymask; @return{'month', 'year'} = $cust_main->paydate_monthyear; } @@ -172,7 +183,7 @@ sub edit_info { if ( $p->{'payby'} =~ /^(CARD|DCRD)$/ ) { $new->paydate($p->{'year'}. '-'. $p->{'month'}. '-01'); - if ( $new->payinfo eq $cust_main->payinfo_masked ) { + if ( $new->payinfo eq $cust_main->paymask ) { $new->payinfo($cust_main->payinfo); } else { $new->paycvv($p->{'paycvv'}); @@ -204,33 +215,30 @@ sub payment_info { #generic ## - my $conf = new FS::Conf; - my %states = map { $_->state => 1 } - qsearch('cust_main_county', { - 'country' => $conf->config('countrydefault') || 'US' - } ); - use vars qw($payment_info); #cache for performance - $payment_info ||= { + unless ( $payment_info ) { - #list all counties/states/countries - 'cust_main_county' => - [ map { $_->hashref } qsearch('cust_main_county', {}) ], + my $conf = new FS::Conf; + my %states = map { $_->state => 1 } + qsearch('cust_main_county', { + 'country' => $conf->config('countrydefault') || 'US' + } ); - #shortcut for one-country folks - 'states' => - [ sort { $a cmp $b } keys %states ], + $payment_info = { - 'card_types' => { - 'VISA' => 'VISA card', - 'MasterCard' => 'MasterCard', - 'Discover' => 'Discover card', - 'American Express' => 'American Express card', - 'Switch' => 'Switch', - 'Solo' => 'Solo', - }, + #list all counties/states/countries + 'cust_main_county' => + [ map { $_->hashref } qsearch('cust_main_county', {}) ], - }; + #shortcut for one-country folks + 'states' => + [ sort { $a cmp $b } keys %states ], + + 'card_types' => card_types(), + + }; + + } ## #customer-specific @@ -253,7 +261,7 @@ sub payment_info { $return{payby} = $cust_main->payby; if ( $cust_main->payby =~ /^(CARD|DCRD)$/ ) { - #warn $return{card_type} = cardtype($cust_main->payinfo); + $return{card_type} = cardtype($cust_main->payinfo); $return{payinfo} = $cust_main->payinfo; @return{'month', 'year'} = $cust_main->paydate_monthyear; @@ -318,17 +326,15 @@ sub process_payment { return { 'error' => gettext('unknown_card_type') } if cardtype($payinfo) eq "Unknown"; - if ( defined $cust_main->dbdef_table->column('paycvv') ) { - if ( length($p->{'paycvv'} ) ) { - if ( cardtype($payinfo) eq 'American Express card' ) { - $p->{'paycvv'} =~ /^(\d{4})$/ - or return { 'error' => "CVV2 (CID) for American Express cards is four digits." }; - $paycvv = $1; - } else { - $p->{'paycvv'} =~ /^(\d{3})$/ - or return { 'error' => "CVV2 (CVC2/CID) is three digits." }; - $paycvv = $1; - } + if ( length($p->{'paycvv'}) && $p->{'paycvv'} !~ /^\s*$/ ) { + if ( cardtype($payinfo) eq 'American Express card' ) { + $p->{'paycvv'} =~ /^\s*(\d{4})\s*$/ + or return { 'error' => "CVV2 (CID) for American Express cards is four digits." }; + $paycvv = $1; + } else { + $p->{'paycvv'} =~ /^\s*(\d{3})\s*$/ + or return { 'error' => "CVV2 (CVC2/CID) is three digits." }; + $paycvv = $1; } } @@ -380,18 +386,27 @@ sub process_prepay { my $cust_main = qsearchs('cust_main', { 'custnum' => $custnum } ) or return { 'error' => "unknown custnum $custnum" }; - my( $amount, $seconds ) = ( 0, 0 ); + my( $amount, $seconds, $upbytes, $downbytes, $totalbytes ) = ( 0, 0, 0, 0, 0 ); my $error = $cust_main->recharge_prepay( $p->{'prepaid_cardnum'}, \$amount, - \$seconds + \$seconds, + \$upbytes, + \$downbytes, + \$totalbytes, ); return { 'error' => $error } if $error; - return { 'error' => '', - 'amount' => $amount, - 'seconds' => $seconds, - 'duration' => duration_exact($seconds), + return { 'error' => '', + 'amount' => $amount, + 'seconds' => $seconds, + 'duration' => duration_exact($seconds), + 'upbytes' => $upbytes, + 'upload' => FS::UI::Web::bytecount_unexact($upbytes), + 'downbytes' => $downbytes, + 'download' => FS::UI::Web::bytecount_unexact($downbytes), + 'totalbytes'=> $totalbytes, + 'totalload' => FS::UI::Web::bytecount_unexact($totalbytes), }; } @@ -414,10 +429,37 @@ sub invoice { return { 'error' => '', 'invnum' => $invnum, 'invoice_text' => join('', $cust_bill->print_text ), + 'invoice_html' => $cust_bill->print_html, }; } +sub invoice_logo { + my $p = shift; + + #sessioning for this? how do we get the session id to the backend invoice + # template so it can add it to the link, blah + + my $templatename = $p->{'templatename'}; + + #false laziness-ish w/view/cust_bill-logo.cgi + + my $conf = new FS::Conf; + if ( $templatename =~ /^([^\.\/]*)$/ && $conf->exists("logo_$1.png") ) { + $templatename = "_$1"; + } else { + $templatename = ''; + } + + my $filename = "logo$templatename.png"; + + return { 'error' => '', + 'logo' => $conf->config_binary($filename), + 'content_type' => 'image/png', #should allow gif, jpg too + }; +} + + sub list_invoices { my $p = shift; my $session = _cache->get($p->{'session_id'}) @@ -499,6 +541,141 @@ sub list_pkgs { } +sub list_svcs { + my $p = shift; + + my($context, $session, $custnum) = _custoragent_session_custnum($p); + return { 'error' => $session } if $context eq 'error'; + + my $search = { 'custnum' => $custnum }; + $search->{'agentnum'} = $session->{'agentnum'} if $context eq 'agent'; + my $cust_main = qsearchs('cust_main', $search ) + or return { 'error' => "unknown custnum $custnum" }; + + my @cust_svc = (); + #foreach my $cust_pkg ( $cust_main->ncancelled_pkgs ) { + foreach my $cust_pkg ( $p->{'ncancelled'} + ? $cust_main->ncancelled_pkgs + : $cust_main->unsuspended_pkgs ) { + push @cust_svc, @{[ $cust_pkg->cust_svc ]}; #@{[ ]} to force array context + } + @cust_svc = grep { $_->part_svc->svcdb eq $p->{'svcdb'} } @cust_svc + if $p->{'svcdb'}; + + #@svc_x = sort { $a->domain cmp $b->domain || $a->username cmp $b->username } + # @svc_x; + + { + #no#'svcnum' => $session->{'svcnum'}, + 'custnum' => $custnum, + 'svcs' => [ map { + my $svc_x = $_->svc_x; + my($label, $value) = $_->label; + my $part_pkg = $svc_x->cust_svc->cust_pkg->part_pkg; + + { 'svcnum' => $_->svcnum, + 'label' => $label, + 'value' => $value, + 'username' => $svc_x->username, + 'email' => $svc_x->email, + 'seconds' => $svc_x->seconds, + 'upbytes' => $svc_x->upbytes, + 'downbytes' => $svc_x->downbytes, + 'totalbytes'=> $svc_x->totalbytes, + 'recharge_amount' => $part_pkg->option('recharge_amount', 1), + 'recharge_seconds' => $part_pkg->option('recharge_seconds', 1), + 'recharge_upbytes' => $part_pkg->option('recharge_upbytes', 1), + 'recharge_downbytes' => $part_pkg->option('recharge_downbytes', 1), + 'recharge_totalbytes' => $part_pkg->option('recharge_totalbytes', 1), + # more... + }; + } + @cust_svc + ], + }; + +} + +sub list_svc_usage { + my $p = shift; + + my($context, $session, $custnum) = _custoragent_session_custnum($p); + return { 'error' => $session } if $context eq 'error'; + + my $search = { 'svcnum' => $p->{'svcnum'} }; + $search->{'agentnum'} = $session->{'agentnum'} if $context eq 'agent'; + my $svc_acct = qsearchs ( 'svc_acct', $search ); + return { 'error' => 'No service selected in list_svc_usage' } + unless $svc_acct; + + my $freq = $svc_acct->cust_svc->cust_pkg->part_pkg->freq; + my $start = $svc_acct->cust_svc->cust_pkg->setup; + #my $end = $svc_acct->cust_svc->cust_pkg->bill; # or time? + my $end = time; + + unless($p->{beginning}){ + $p->{beginning} = $svc_acct->cust_svc->cust_pkg->last_bill; + $p->{ending} = $end; + } + my @usage = (); + + foreach my $part_export ( + map { qsearch ( 'part_export', { 'exporttype' => $_ } ) } + qw (sqlradius sqlradius_withdomain') + ) { + + push @usage, @ { $part_export->usage_sessions($p->{beginning}, + $p->{ending}, + $svc_acct) + }; + } + + #kinda false laziness with FS::cust_main::bill, but perhaps + #we should really change this bit to DateTime and DateTime::Duration + # + #change this bit to use Date::Manip? CAREFUL with timezones (see + # mailing list archive) + my ($nsec,$nmin,$nhour,$nmday,$nmon,$nyear) = + (localtime($p->{ending}) )[0,1,2,3,4,5]; + my ($psec,$pmin,$phour,$pmday,$pmon,$pyear) = + (localtime($p->{beginning}) )[0,1,2,3,4,5]; + + if ( $freq =~ /^\d+$/ ) { + $nmon += $freq; + until ( $nmon < 12 ) { $nmon -= 12; $nyear++; } + $pmon -= $freq; + until ( $pmon >= 0 ) { $pmon += 12; $pyear--; } + } elsif ( $freq =~ /^(\d+)w$/ ) { + my $weeks = $1; + $nmday += $weeks * 7; + $pmday -= $weeks * 7; + } elsif ( $freq =~ /^(\d+)d$/ ) { + my $days = $1; + $nmday += $days; + $pmday -= $days; + } elsif ( $freq =~ /^(\d+)h$/ ) { + my $hours = $1; + $nhour += $hours; + $phour -= $hours; + } else { + return { 'error' => "unparsable frequency: ". $freq }; + } + + my $previous = timelocal_nocheck($psec,$pmin,$phour,$pmday,$pmon,$pyear); + my $next = timelocal_nocheck($nsec,$nmin,$nhour,$nmday,$nmon,$nyear); + + + { + 'error' => '', + 'svcnum' => $p->{svcnum}, + 'beginning' => $p->{beginning}, + 'ending' => $p->{ending}, + 'previous' => ($previous > $start) ? $previous : $start, + 'next' => ($next < $end) ? $next : $end, + 'usage' => \@usage, + }; +} + sub order_pkg { my $p = shift; @@ -535,7 +712,7 @@ sub order_pkg { $svcpart ||= $cust_pkg->part_pkg->svcpart($svcdb); my %fields = ( - 'svc_acct' => [ qw( username _password sec_phrase popnum ) ], + 'svc_acct' => [ qw( username domsvc _password sec_phrase popnum ) ], 'svc_domain' => [ qw( domain ) ], 'svc_external' => [ qw( id title ) ], ); @@ -581,12 +758,126 @@ sub order_pkg { my $conf = new FS::Conf; if ( $conf->exists('signup_server-realtime') ) { + my $bill_error = _do_bop_realtime( $cust_main ); + + if ($bill_error) { + $cust_pkg->cancel('quiet'=>1); + return $bill_error; + } else { + $cust_pkg->reexport; + } + + } else { + $cust_pkg->reexport; + } + + return { error => '', pkgnum => $cust_pkg->pkgnum }; + +} + +sub change_pkg { + my $p = shift; + + my($context, $session, $custnum) = _custoragent_session_custnum($p); + return { 'error' => $session } if $context eq 'error'; + + my $search = { 'custnum' => $custnum }; + $search->{'agentnum'} = $session->{'agentnum'} if $context eq 'agent'; + my $cust_main = qsearchs('cust_main', $search ) + or return { 'error' => "unknown custnum $custnum" }; + + my $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $p->{pkgnum} } ) + or return { 'error' => "unknown package $p->{pkgnum}" }; + + my @newpkg; + my $error = FS::cust_pkg::order( $custnum, + [$p->{pkgpart}], + [$p->{pkgnum}], + \@newpkg, + ); + + my $conf = new FS::Conf; + if ( $conf->exists('signup_server-realtime') ) { + + my $bill_error = _do_bop_realtime( $cust_main ); + + if ($bill_error) { + $newpkg[0]->suspend; + return $bill_error; + } else { + $newpkg[0]->reexport; + } + + } else { + $newpkg[0]->reexport; + } + + return { error => '', pkgnum => $cust_pkg->pkgnum }; + +} + +sub order_recharge { + my $p = shift; + + my($context, $session, $custnum) = _custoragent_session_custnum($p); + return { 'error' => $session } if $context eq 'error'; + + my $search = { 'custnum' => $custnum }; + $search->{'agentnum'} = $session->{'agentnum'} if $context eq 'agent'; + my $cust_main = qsearchs('cust_main', $search ) + or return { 'error' => "unknown custnum $custnum" }; + + my $cust_svc = qsearchs( 'cust_svc', { 'svcnum' => $p->{'svcnum'} } ) + or return { 'error' => "unknown service " . $p->{'svcnum'} }; + + my $svc_x = $cust_svc->svc_x; + my $part_pkg = $cust_svc->cust_pkg->part_pkg; + + my %vhash = + map { $_ =~ /^recharge_(.*)$/; $1, $part_pkg->option($_, 1) } + qw ( recharge_seconds recharge_upbytes recharge_downbytes + recharge_totalbytes ); + my $amount = $part_pkg->option('recharge_amount', 1); + + my ($l, $v, $d) = $cust_svc->label; # blah + my $pkg = "Recharge $v"; + + my $bill_error = $cust_main->charge($amount, $pkg, + "time: $vhash{seconds}, up: $vhash{upbytes}," . + "down: $vhash{downbytes}, total: $vhash{totalbytes}", + $part_pkg->taxclass); #meh + + my $conf = new FS::Conf; + if ( $conf->exists('signup_server-realtime') && !$bill_error ) { + + $bill_error = _do_bop_realtime( $cust_main ); + + if ('bill_error') { + return $bill_error; + } else { + my $error = $svc_x->recharge (\%vhash); + return { 'error' => $error } if $error; + } + + } else { + my $error = $bill_error; + $error ||= $svc_x->recharge (\%vhash); + return { 'error' => $error } if $error; + } + + return { error => '', svc => $cust_svc->part_svc->svc }; + +} + +sub _do_bop_realtime { + my ($cust_main) = @_; + my $old_balance = $cust_main->balance; my $bill_error = $cust_main->bill; - $cust_main->apply_payments; - $cust_main->apply_credits; - $bill_error = $cust_main->collect; + + $cust_main->apply_payments_and_credits; + $bill_error = $cust_main->collect('realtime' => 1); if ( $cust_main->balance > $old_balance && $cust_main->balance > 0 @@ -596,18 +887,10 @@ sub order_pkg { 'self-service decline' ); $cust_main->apply_credits( 'order' => 'newest' ); - $cust_pkg->cancel('quiet'=>1); return { 'error' => '_decline', 'bill_error' => $bill_error }; - } else { - $cust_pkg->reexport; } - } else { - $cust_pkg->reexport; - } - - return { error => '', pkgnum => $cust_pkg->pkgnum }; - + ''; } sub cancel_pkg { @@ -772,6 +1055,45 @@ sub unprovision_svc { } +sub myaccount_passwd { + my $p = shift; + my($context, $session, $custnum) = _custoragent_session_custnum($p); + return { 'error' => $session } if $context eq 'error'; + + return { 'error' => "New passwords don't match." } + if $p->{'new_password'} ne $p->{'new_password2'}; + + return { 'error' => 'Enter new password' } + unless length($p->{'new_password'}); + + #my $search = { 'custnum' => $custnum }; + #$search->{'agentnum'} = $session->{'agentnum'} if $context eq 'agent'; + $custnum =~ /^(\d+)$/ or die "illegal custnum"; + my $search = " AND custnum = $1"; + $search .= " AND agentnum = ". $session->{'agentnum'} if $context eq 'agent'; + + my $svc_acct = qsearchs( { + 'table' => 'svc_acct', + 'addl_from' => 'LEFT JOIN cust_svc USING ( svcnum ) '. + 'LEFT JOIN cust_pkg USING ( pkgnum ) '. + 'LEFT JOIN cust_main USING ( custnum ) ', + 'hashref' => { 'svcnum' => $p->{'svcnum'}, }, + 'extra_sql' => $search, #important + } ) + or return { 'error' => "Service not found" }; + + $svc_acct->_password($p->{'new_password'}); + my $error = $svc_acct->replace(); + + my($label, $value) = $svc_acct->cust_svc->label; + + return { 'error' => $error, + 'label' => $label, + 'value' => $value, + }; + +} + #-- sub _custoragent_session_custnum { diff --git a/FS/FS/ClientAPI/Signup.pm b/FS/FS/ClientAPI/Signup.pm index ed71651fa..ac211ec27 100644 --- a/FS/FS/ClientAPI/Signup.pm +++ b/FS/FS/ClientAPI/Signup.pm @@ -5,6 +5,7 @@ use Tie::RefHash; use FS::Conf; use FS::Record qw(qsearch qsearchs dbdef); use FS::Msgcat qw(gettext); +use FS::Misc qw(card_types); use FS::ClientAPI_SessionCache; use FS::agent; use FS::cust_main_county; @@ -22,29 +23,21 @@ sub signup_info { my $conf = new FS::Conf; - use vars qw($signup_info); #cache for performance; - $signup_info ||= { - + use vars qw($signup_info_cache); #cache for performance; + $signup_info_cache ||= { 'cust_main_county' => [ map { $_->hashref } qsearch('cust_main_county', {}) ], 'agent' => [ map { $_->hashref } - qsearch('agent', dbdef->table('agent')->column('disabled') - ? { 'disabled' => '' } - : {} - ) + qsearch('agent', { 'disabled' => '' } ) ], 'part_referral' => [ map { $_->hashref } - qsearch('part_referral', - dbdef->table('part_referral')->column('disabled') - ? { 'disabled' => '' } - : {} - ) + qsearch('part_referral', { 'disabled' => '' }) ], 'agentnum2part_pkg' => @@ -53,28 +46,33 @@ sub signup_info { my $href = $_->pkgpart_hashref; $_->agentnum => [ - map { { 'payby' => [ $_->payby ], %{$_->hashref} } } + map { { 'payby' => [ $_->payby ], + 'freq_pretty' => $_->freq_pretty, + 'options' => { $_->options }, + %{$_->hashref} + } } grep { $_->svcpart('svc_acct') && $href->{ $_->pkgpart } } qsearch( 'part_pkg', { 'disabled' => '' } ) ]; - } qsearch('agent', dbdef->table('agent')->column('disabled') - ? { 'disabled' => '' } - : {} - ) + } qsearch('agent', { 'disabled' => '' }) }, 'svc_acct_pop' => [ map { $_->hashref } qsearch('svc_acct_pop',{} ) ], + 'emailinvoiceonly' => $conf->exists('emailinvoiceonly'), + 'security_phrase' => $conf->exists('security_phrase'), 'payby' => [ $conf->config('signup_server-payby') ], - 'cvv_enabled' => defined dbdef->table('cust_main')->column('paycvv'), + 'card_types' => card_types(), + + 'cvv_enabled' => defined dbdef->table('cust_main')->column('paycvv'), # 1, - 'ship_enabled' => defined dbdef->table('cust_main')->column('ship_last'), + 'ship_enabled' => defined dbdef->table('cust_main')->column('ship_last'),#1, 'msgcat' => { map { $_=>gettext($_) } qw( - passwords_dont_match invalid_card unknown_card_type not_a empty_password + passwords_dont_match invalid_card unknown_card_type not_a empty_password illegal_or_empty_text ) }, 'statedefault' => $conf->config('statedefault') || 'CA', @@ -83,9 +81,39 @@ sub signup_info { 'refnum' => $conf->config('signup_server-default_refnum'), + 'default_pkgpart' => $conf->config('signup_server-default_pkgpart'), + }; - my $agentnum = $conf->config('signup_server-default_agentnum'); + my $signup_info = { %$signup_info_cache }; + + my @addl = qw( signup_server-classnum2 signup_server-classnum3 ); + + if ( grep { $conf->exists($_) } @addl ) { + + $signup_info->{optional_packages} = []; + + foreach my $addl ( @addl ) { + my $classnum = $conf->config($addl) or next; + + my @pkgs = map { { + 'freq_pretty' => $_->freq_pretty, + 'options' => { $_->options }, + %{ $_->hashref } + }; + } + qsearch( 'part_pkg', { classnum => $classnum } ); + + push @{$signup_info->{optional_packages}}, \@pkgs; + + } + + } + + my $agentnum = $packet->{'agentnum'} + || $conf->config('signup_server-default_agentnum'); + $agentnum =~ /^(\d*)$/ or die "illegal agentnum"; + $agentnum = $1; my $session = ''; if ( exists $packet->{'session_id'} ) { @@ -98,13 +126,31 @@ sub signup_info { } else { return { 'error' => "Can't resume session" }; #better error message } + }elsif( exists $packet->{'customer_session_id'} ) { + my $cache = new FS::ClientAPI_SessionCache( { + 'namespace' => 'FS::ClientAPI::MyAccount', + } ); + $session = $cache->get($packet->{'customer_session_id'}); + if ( $session ) { + my $custnum = $session->{'custnum'}; + my $cust_main = qsearchs('cust_main', { 'custnum' => $custnum }); + return { 'error' => "Can't find your customer record" } unless $cust_main; + $agentnum = $cust_main->agentnum; + } else { + return { 'error' => "Can't resume session" }; #better error message + } } $signup_info->{'part_pkg'} = []; if ( $packet->{'reg_code'} ) { $signup_info->{'part_pkg'} = - [ map { { 'payby' => [ $_->payby ], %{$_->hashref} } } + [ map { { 'payby' => [ $_->payby ], + 'freq_pretty' => $_->freq_pretty, + 'options' => { $_->options }, + %{$_->hashref} + }; + } grep { $_->svcpart('svc_acct') } map { $_->part_pkg } qsearchs( 'reg_code', { 'code' => $packet->{'reg_code'}, @@ -118,7 +164,11 @@ sub signup_info { } elsif ( $packet->{'promo_code'} ) { $signup_info->{'part_pkg'} = - [ map { { 'payby' => [ $_->payby ], %{$_->hashref} } } + [ map { { 'payby' => [ $_->payby ], + 'freq_pretty' => $_->freq_pretty, + 'options' => { $_->options }, + %{$_->hashref} + } } grep { $_->svcpart('svc_acct') } qsearch( 'part_pkg', { 'promo_code' => { op=>'ILIKE', @@ -133,12 +183,29 @@ sub signup_info { if ( $agentnum && ! @{ $signup_info->{'part_pkg'} } ) { $signup_info->{'part_pkg'} = $signup_info->{'agentnum2part_pkg'}{$agentnum}; + + $signup_info->{'part_referral'} = + [ + map { $_->hashref } + qsearch( { + 'table' => 'part_referral', + 'hashref' => { 'disabled' => '' }, + 'extra_sql' => "AND ( agentnum = $agentnum ". + " OR agentnum IS NULL ) ", + }, + ) + ]; + } # else { # delete $signup_info->{'part_pkg'}; #} - if ( $session ) { + $signup_info->{'part_pkg'} = [ sort { $a->{pkg} cmp $b->{pkg} } # case? + @{ $signup_info->{'part_pkg'} } + ]; + + if ( exists $packet->{'session_id'} ) { my $agent_signup_info = { %$signup_info }; delete $agent_signup_info->{agentnum2part_pkg}; $agent_signup_info->{'agent'} = $session->{'agent'}; @@ -214,7 +281,9 @@ sub new_customer { $cust_main->payinfo($cust_main->daytime) if $cust_main->payby eq 'LECB' && ! $cust_main->payinfo; - my @invoicing_list = split( /\s*\,\s*/, $packet->{'invoicing_list'} ); + my @invoicing_list = $packet->{'invoicing_list'} + ? split( /\s*\,\s*/, $packet->{'invoicing_list'} ) + : (); $packet->{'pkgpart'} =~ /^(\d+)$/ or '' =~ /^()$/; my $pkgpart = $1; @@ -299,10 +368,9 @@ sub new_customer { #warn "[fs_signup_server] error billing new customer: $bill_error" # if $bill_error; - $cust_main->apply_payments; - $cust_main->apply_credits; + $cust_main->apply_payments_and_credits; - $bill_error = $cust_main->collect; + $bill_error = $cust_main->collect('realtime' => 1); #warn "[fs_signup_server] error collecting from new customer: $bill_error" # if $bill_error; diff --git a/FS/FS/Conf.pm b/FS/FS/Conf.pm index 88dbdf082..8db0b0c6a 100644 --- a/FS/FS/Conf.pm +++ b/FS/FS/Conf.pm @@ -1,9 +1,14 @@ package FS::Conf; -use vars qw($default_dir @config_items $DEBUG ); +use vars qw($default_dir $base_dir @config_items @card_types $DEBUG ); use IO::File; use File::Basename; use FS::ConfItem; +use FS::ConfDefaults; + +$base_dir = '%%%FREESIDE_CONF%%%'; +$default_dir = '%%%FREESIDE_CONF%%%'; + $DEBUG = 0; @@ -51,13 +56,15 @@ $FS::Conf::default_dir has not been set. sub new { my($proto,$dir) = @_; my($class) = ref($proto) || $proto; - my($self) = { 'dir' => $dir || $default_dir } ; + my($self) = { 'dir' => $dir || $default_dir, + 'base_dir' => $base_dir, + }; bless ($self, $class); } =item dir -Returns the directory. +Returns the conf directory. =cut @@ -72,6 +79,23 @@ sub dir { $1; } +=item base_dir + +Returns the base directory. By default this is /usr/local/etc/freeside. + +=cut + +sub base_dir { + my($self) = @_; + my $base_dir = $self->{base_dir}; + -e $base_dir or die "FATAL: $base_dir doesn't exist!"; + -d $base_dir or die "FATAL: $base_dir isn't a directory!"; + -r $base_dir or die "FATAL: Can't read $base_dir!"; + -x $base_dir or die "FATAL: $base_dir not searchable (executable)!"; + $base_dir =~ /^(.*)$/; + $1; +} + =item config KEY Returns the configuration value or values (depending on context) for key. @@ -283,6 +307,20 @@ httemplate/docs/config.html =cut +#Business::CreditCard +@card_types = ( + "VISA card", + "MasterCard", + "Discover card", + "American Express card", + "Diner's Club/Carte Blanche", + "enRoute", + "JCB", + "BankCard", + "Switch", + "Solo", +); + @config_items = map { new FS::ConfItem $_ } ( { @@ -412,6 +450,17 @@ httemplate/docs/config.html }, { + 'key' => 'date_format', + 'section' => 'UI', + 'description' => 'Format for displaying dates', + 'type' => 'select', + 'select_hash' => [ + '%m/%d/%Y' => 'MM/DD/YYYY', + '%Y/%m/%d' => 'YYYY/MM/DD', + ], + }, + + { 'key' => 'cyrus', 'section' => 'deprecated', 'description' => '<b>DEPRECATED</b>, add a <i>cyrus</i> <a href="../browse/part_export.cgi">export</a> instead. This option used to integrate 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.', @@ -434,29 +483,36 @@ httemplate/docs/config.html { 'key' => 'deletepayments', - 'section' => 'UI', - 'description' => 'Enable deletion of unclosed payments. Be very careful! Only delete payments that were data-entry errors, not adjustments. Optionally specify one or more comma-separated email addresses to be notified when a payment is deleted.', + 'section' => 'billing', + 'description' => 'Enable deletion of unclosed payments. Really, with voids this is pretty much not recommended in any situation anymore. Be very careful! Only delete payments that were data-entry errors, not adjustments. Optionally specify one or more comma-separated email addresses to be notified when a payment is deleted.', 'type' => [qw( checkbox text )], }, { 'key' => 'deletecredits', - 'section' => 'UI', - 'description' => 'Enable deletion of unclosed credits. Be very careful! Only delete credits that were data-entry errors, not adjustments. Optionally specify one or more comma-separated email addresses to be notified when a credit is deleted.', + 'section' => 'deprecated', + 'description' => '<B>DEPRECATED</B>, now controlled by ACLs. Used to enable deletion of unclosed credits. Be very careful! Only delete credits that were data-entry errors, not adjustments. Optionally specify one or more comma-separated email addresses to be notified when a credit is deleted.', 'type' => [qw( checkbox text )], }, { + 'key' => 'deleterefunds', + 'section' => 'billing', + 'description' => 'Enable deletion of unclosed refunds. Be very careful! Only delete refunds that were data-entry errors, not adjustments.', + 'type' => 'checkbox', + }, + + { 'key' => 'unapplypayments', - 'section' => 'UI', - 'description' => 'Enable "unapplication" of unclosed payments.', + 'section' => 'deprecated', + 'description' => '<B>DEPRECATED</B>, now controlled by ACLs. Used to enable "unapplication" of unclosed payments.', 'type' => 'checkbox', }, { 'key' => 'unapplycredits', - 'section' => 'UI', - 'description' => 'Enable "unapplication" of unclosed credits.', + 'section' => 'deprecated', + 'description' => '<B>DEPRECATED</B>, now controlled by ACLs. Used to nable "unapplication" of unclosed credits.', 'type' => 'checkbox', }, @@ -503,6 +559,13 @@ httemplate/docs/config.html }, { + 'key' => 'emailinvoiceautoalways', + 'section' => 'billing', + 'description' => 'Automatically adds new accounts to the email invoice list even when the list contains email addresses', + 'type' => 'checkbox', + }, + + { 'key' => 'exclude_ip_addr', 'section' => '', 'description' => 'Exclude these from the list of available broadband service IP addresses. (One per line)', @@ -988,6 +1051,13 @@ httemplate/docs/config.html }, { + 'key' => 'unsuspend-always_adjust_next_bill_date', + 'section' => 'billing', + 'description' => 'Global override that causes unsuspensions to always adjust the next bill date under any circumstances. This is now controlled on a per-package bases - probably best not to use this option unless you are a legacy installation that requires this behaviour.', + 'type' => 'checkbox', + }, + + { 'key' => 'usernamemin', 'section' => 'username', 'description' => 'Minimum username length (default 2)', @@ -1176,15 +1246,63 @@ httemplate/docs/config.html { 'key' => 'signup_server-default_agentnum', 'section' => '', - 'description' => 'Default agentnum for the signup server', - 'type' => 'text', + 'description' => 'Default agent for the signup server', + 'type' => 'select-sub', + 'options_sub' => sub { require FS::Record; + require FS::agent; + map { $_->agentnum => $_->agent } + FS::Record::qsearch('agent', { disabled=>'' } ); + }, + 'option_sub' => sub { require FS::Record; + require FS::agent; + my $agent = FS::Record::qsearchs( + 'agent', { 'agentnum'=>shift } + ); + $agent ? $agent->agent : ''; + }, }, { 'key' => 'signup_server-default_refnum', 'section' => '', - 'description' => 'Default advertising source number for the signup server', - 'type' => 'text', + 'description' => 'Default advertising source for the signup server', + 'type' => 'select-sub', + 'options_sub' => sub { require FS::Record; + require FS::part_referral; + map { $_->refnum => $_->referral } + FS::Record::qsearch( 'part_referral', + { 'disabled' => '' } + ); + }, + 'option_sub' => sub { require FS::Record; + require FS::part_referral; + my $part_referral = FS::Record::qsearchs( + 'part_referral', { 'refnum'=>shift } ); + $part_referral ? $part_referral->referral : ''; + }, + }, + + { + 'key' => 'signup_server-default_pkgpart', + 'section' => '', + 'description' => 'Default pakcage for the signup server', + 'type' => 'select-sub', + 'options_sub' => sub { require FS::Record; + require FS::part_pkg; + map { $_->pkgpart => $_->pkg.' - '.$_->comment } + FS::Record::qsearch( 'part_pkg', + { 'disabled' => ''} + ); + }, + 'option_sub' => sub { require FS::Record; + require FS::part_pkg; + my $part_pkg = FS::Record::qsearchs( + 'part_pkg', { 'pkgpart'=>shift } + ); + $part_pkg + ? $part_pkg->pkg.' - '.$part_pkg->comment + : ''; + }, }, { @@ -1200,6 +1318,43 @@ httemplate/docs/config.html 'description' => 'Run billing for signup server signups immediately, and do not provision accounts which subsequently have a balance.', 'type' => 'checkbox', }, + { + 'key' => 'signup_server-classnum2', + 'section' => '', + 'description' => 'Package Class for first optional purchase', + 'type' => 'select-sub', + 'options_sub' => sub { require FS::Record; + require FS::pkg_class; + map { $_->classnum => $_->classname } + FS::Record::qsearch('pkg_class', {} ); + }, + 'option_sub' => sub { require FS::Record; + require FS::pkg_class; + my $pkg_class = FS::Record::qsearchs( + 'pkg_class', { 'classnum'=>shift } + ); + $pkg_class ? $pkg_class->classname : ''; + }, + }, + + { + 'key' => 'signup_server-classnum3', + 'section' => '', + 'description' => 'Package Class for second optional purchase', + 'type' => 'select-sub', + 'options_sub' => sub { require FS::Record; + require FS::pkg_class; + map { $_->classnum => $_->classname } + FS::Record::qsearch('pkg_class', {} ); + }, + 'option_sub' => sub { require FS::Record; + require FS::pkg_class; + my $pkg_class = FS::Record::qsearchs( + 'pkg_class', { 'classnum'=>shift } + ); + $pkg_class ? $pkg_class->classname : ''; + }, + }, { 'key' => 'backend-realtime', @@ -1301,6 +1456,42 @@ httemplate/docs/config.html }, { + 'key' => 'warning_email', + 'section' => '', + 'description' => 'Template file for warning email. Warning emails are sent to the customer email invoice destination(s) each time a svc_acct record has its usage drop below a threshold or 0. See the <a href="http://search.cpan.org/~mjd/Text-Template/lib/Text/Template.pm">Text::Template</a> documentation for details on the template substitution language. The following variables are available<ul><li><code>$username</code> <li><code>$password</code> <li><code>$first</code> <li><code>$last</code> <li><code>$pkg</code> <li><code>$column</code> <li><code>$amount</code> <li><code>$threshold</code></ul>', + 'type' => 'textarea', + }, + + { + 'key' => 'warning_email-from', + 'section' => '', + 'description' => 'From: address header for warning email', + 'type' => 'text', + }, + + { + 'key' => 'warning_email-cc', + 'section' => '', + 'description' => 'Additional recipient(s) (comma separated) for warning email when remaining usage reaches zero.', + 'type' => 'text', + }, + + { + 'key' => 'warning_email-subject', + 'section' => '', + 'description' => 'Subject: header for warning email', + 'type' => 'text', + }, + + { + 'key' => 'warning_email-mimetype', + 'section' => '', + 'description' => 'MIME type for warning email', + 'type' => 'select', + 'select_enum' => [ 'text/plain', 'text/html' ], + }, + + { 'key' => 'payby', 'section' => 'billing', 'description' => 'Available payment types.', @@ -1362,8 +1553,8 @@ httemplate/docs/config.html { 'key' => 'users-allow_comp', - 'section' => '', - 'description' => 'Usernames (Freeside users, created with <a href="../docs/man/bin/freeside-adduser.html">freeside-adduser</a>) which can create complimentary customers, one per line. If no usernames are entered, all users can create complimentary accounts.', + 'section' => 'deprecated', + 'description' => '<b>DEPRECATED</b>, enable the <i>Complimentary customer</i> access right instead. Was: Usernames (Freeside users, created with <a href="../docs/man/bin/freeside-adduser.html">freeside-adduser</a>) which can create complimentary customers, one per line. If no usernames are entered, all users can create complimentary accounts.', 'type' => 'textarea', }, @@ -1372,15 +1563,7 @@ httemplate/docs/config.html 'section' => 'billing', 'description' => 'Save CVV2 information after the initial transaction for the selected credit card types. Enabling this option may be in violation of your merchant agreement(s), so please check them carefully before enabling this option for any credit card types.', 'type' => 'selectmultiple', - 'select_enum' => [ "VISA card", - "MasterCard", - "Discover card", - "American Express card", - "Diner's Club/Carte Blanche", - "enRoute", - "JCB", - "BankCard", - ], + 'select_enum' => \@card_types, }, { @@ -1455,9 +1638,9 @@ httemplate/docs/config.html { 'key' => 'global_unique-username', 'section' => 'username', - 'description' => 'Global username uniqueness control: none (usual setting - check uniqueness per exports), username (all usernames are globally unique, regardless of domain or exports), or username@domain (all username@domain pairs are globally unique, regardless of exports)', + 'description' => 'Global username uniqueness control: none (usual setting - check uniqueness per exports), username (all usernames are globally unique, regardless of domain or exports), or username@domain (all username@domain pairs are globally unique, regardless of exports). disabled turns off duplicate checking completely and is STRONGLY NOT RECOMMENDED unless you REALLY need to turn this off.', 'type' => 'select', - 'select_enum' => [ 'none', 'username', 'username@domain' ], + 'select_enum' => [ 'none', 'username', 'username@domain', 'disabled' ], }, { @@ -1556,22 +1739,22 @@ httemplate/docs/config.html { 'key' => 'echeck-void', - 'section' => 'billing', - 'description' => 'Enable local-only voiding of echeck payments in addition to refunds against the payment gateway', + 'section' => 'deprecated', + 'description' => '<B>DEPRECATED</B>, now controlled by ACLs. Used to enable local-only voiding of echeck payments in addition to refunds against the payment gateway', 'type' => 'checkbox', }, { 'key' => 'cc-void', - 'section' => 'billing', - 'description' => 'Enable local-only voiding of credit card payments in addition to refunds against the payment gateway', + 'section' => 'deprecated', + 'description' => '<B>DEPRECATED</B>, now controlled by ACLs. Used to enable local-only voiding of credit card payments in addition to refunds against the payment gateway', 'type' => 'checkbox', }, { 'key' => 'unvoid', - 'section' => 'billing', - 'description' => 'Enable unvoiding of voided payments', + 'section' => 'deprecated', + 'description' => '<B>DEPRECATED</B>, now controlled by ACLs. Used to enable unvoiding of voided payments', 'type' => 'checkbox', }, @@ -1605,32 +1788,30 @@ httemplate/docs/config.html { 'key' => 'svc_acct-usage_suspend', 'section' => 'billing', - 'description' => 'Suspends the package an account belongs to when svc_acct.seconds is decremented to 0 or below (accounts with an empty seconds value are ignored). Typically used in conjunction with prepaid packages and freeside-sqlradius-radacctd.', + 'description' => 'Suspends the package an account belongs to when svc_acct.seconds or a bytecount is decremented to 0 or below (accounts with an empty seconds and up|down|totalbytes value are ignored). Typically used in conjunction with prepaid packages and freeside-sqlradius-radacctd.', 'type' => 'checkbox', }, { 'key' => 'svc_acct-usage_unsuspend', 'section' => 'billing', - 'description' => 'Unuspends the package an account belongs to when svc_acct.seconds is incremented from 0 or below to a positive value (accounts with an empty seconds value are ignored). Typically used in conjunction with prepaid packages and freeside-sqlradius-radacctd.', + 'description' => 'Unuspends the package an account belongs to when svc_acct.seconds or a bytecount is incremented from 0 or below to a positive value (accounts with an empty seconds and up|down|totalbytes value are ignored). Typically used in conjunction with prepaid packages and freeside-sqlradius-radacctd.', 'type' => 'checkbox', }, { + 'key' => 'svc_acct-usage_threshold', + 'section' => 'billing', + 'description' => 'The threshold (expressed as percentage) of acct.seconds or acct.up|down|totalbytes at which a warning message is sent to a service holder. Typically used in conjunction with prepaid packages and freeside-sqlradius-radacctd. Defaults to 80.', + 'type' => 'text', + }, + + { 'key' => 'cust-fields', 'section' => 'UI', - 'description' => 'Which customer fields to display on reports', + 'description' => 'Which customer fields to display on reports by default', 'type' => 'select', - 'select_enum' => [ - 'Customer: Last, First</b> or</i> Company (Last, First)</b>', - 'Cust# | Customer: custnum | Last, First or Company (Last, First)', - 'Name | Company: Last, First | Company', - 'Cust# | Name | Company: custnum | Last, First | Company', - '(bill) Customer | (service) Customer: Last, First or Company (Last, First) | (same for service address if present)', - 'Cust# | (bill) Customer | (service) Customer: custnum | Last, First or Company (Last, First) | (same for service address if present)', - '(bill) Name | (bill) Company | (service) Name | (service) Company: Last, First | Company | (same for service address if present)', - 'Cust# | (bill) Name | (bill) Company | (service) Name | (service) Company: custnum | Last, First | Company | (same for service address if present)', - ], + 'select_hash' => [ FS::ConfDefaults->cust_fields_avail() ], }, { @@ -1661,6 +1842,209 @@ httemplate/docs/config.html 'type' => 'checkbox', }, + #these should become per-user... + { + 'key' => 'vonage-username', + 'section' => '', + 'description' => 'Vonage Click2Call username (see <a href="https://secure.click2callu.com/">https://secure.click2callu.com/</a>)', + 'type' => 'text', + }, + { + 'key' => 'vonage-password', + 'section' => '', + 'description' => 'Vonage Click2Call username (see <a href="https://secure.click2callu.com/">https://secure.click2callu.com/</a>)', + 'type' => 'text', + }, + { + 'key' => 'vonage-fromnumber', + 'section' => '', + 'description' => 'Vonage Click2Call number (see <a href="https://secure.click2callu.com/">https://secure.click2callu.com/</a>)', + 'type' => 'text', + }, + + { + 'key' => 'echeck-nonus', + 'section' => 'billing', + 'description' => 'Disable ABA-format account checking for Electronic Check payment info', + 'type' => 'checkbox', + }, + + { + 'key' => 'voip-cust_cdr_spools', + 'section' => '', + 'description' => 'Enable the per-customer option for individual CDR spools.', + 'type' => 'checkbox', + }, + + { + 'key' => 'svc_forward-arbitrary_dst', + 'section' => '', + 'description' => "Allow forwards to point to arbitrary strings that don't necessarily look like email addresses. Only used when using forwards for weird, non-email things.", + 'type' => 'checkbox', + }, + + { + 'key' => 'tax-ship_address', + 'section' => 'billing', + 'description' => 'By default, tax calculations are done based on the billing address. Enable this switch to calculate tax based on the shipping address instead. Note: Tax reports can take a long time when enabled.', + 'type' => 'checkbox', + }, + + { + 'key' => 'batch-enable', + 'section' => 'billing', + 'description' => 'Enable credit card batching - leave disabled for real-time installations.', + 'type' => 'checkbox', + }, + + { + 'key' => 'batch-default_format', + 'section' => 'billing', + 'description' => 'Default format for batches.', + 'type' => 'select', + 'select_enum' => [ 'csv-td_canada_trust-merchant_pc_batch', + 'csv-chase_canada-E-xactBatch', 'BoM', 'PAP' ] + }, + + { + 'key' => 'batch-fixed_format-CARD', + 'section' => 'billing', + 'description' => 'Fixed (unchangeable) format for credit card batches.', + 'type' => 'select', + 'select_enum' => [ 'csv-td_canada_trust-merchant_pc_batch', 'BoM', 'PAP' , + 'csv-chase_canada-E-xactBatch', 'BoM', 'PAP' ] + }, + + { + 'key' => 'batch-fixed_format-CHEK', + 'section' => 'billing', + 'description' => 'Fixed (unchangeable) format for electronic check batches.', + 'type' => 'select', + 'select_enum' => [ 'csv-td_canada_trust-merchant_pc_batch', 'BoM', 'PAP' ] + }, + + { + 'key' => 'batch-increment_expiration', + 'section' => 'billing', + 'description' => 'Increment expiration date years in batches until cards are current. Make sure this is acceptable to your batching provider before enabling.', + 'type' => 'checkbox' + }, + + { + 'key' => 'batchconfig-BoM', + 'section' => 'billing', + 'description' => 'Configuration for Bank of Montreal batching, seven lines: 1. Origin ID, 2. Datacenter, 3. Typecode, 4. Short name, 5. Long name, 6. Bank, 7. Bank account', + 'type' => 'textarea', + }, + + { + 'key' => 'batchconfig-PAP', + 'section' => 'billing', + 'description' => 'Configuration for PAP batching, seven lines: 1. Origin ID, 2. Datacenter, 3. Typecode, 4. Short name, 5. Long name, 6. Bank, 7. Bank account', + 'type' => 'textarea', + }, + + { + 'key' => 'batchconfig-csv-chase_canada-E-xactBatch', + 'section' => 'billing', + 'description' => 'Gateway ID for Chase Canada E-xact batching', + 'type' => 'text', + }, + + { + 'key' => 'payment_history-years', + 'section' => 'UI', + 'description' => 'Number of years of payment history to show by default. Currently defaults to 2.', + 'type' => 'text', + }, + + { + 'key' => 'cust_main-use_comments', + 'section' => 'UI', + 'description' => 'Display free form comments on the customer edit screen. Useful as a scratch pad.', + 'type' => 'checkbox', + }, + + { + 'key' => 'cust_main-disable_notes', + 'section' => 'UI', + 'description' => 'Disable new style customer notes - timestamped and user identified customer notes. Useful in tracking who did what.', + 'type' => 'checkbox', + }, + + { + 'key' => 'cust_main_note-display_times', + 'section' => 'UI', + 'description' => 'Display full timestamps (not just dates) for customer notes.', + 'type' => 'checkbox', + }, + + { + 'key' => 'cust_main-ticket_statuses', + 'section' => 'UI', + 'description' => 'Show tickets with these statuses on the customer view page.', + 'type' => 'selectmultiple', + 'select_enum' => [qw( new open stalled resolved rejected deleted )], + }, + + { + 'key' => 'cust_main-max_tickets', + 'section' => 'UI', + 'description' => 'Maximum number of tickets to show on the customer view page.', + 'type' => 'text', + }, + + { + 'key' => 'cust_main-skeleton_tables', + 'section' => '', + 'description' => 'Tables which will have skeleton records inserted into them for each customer. Syntax for specifying tables is unfortunately a tricky perl data structure for now.', + 'type' => 'textarea', + }, + + { + 'key' => 'cust_main-skeleton_custnum', + 'section' => '', + 'description' => 'Customer number specifying the source data to copy into skeleton tables for new customers.', + 'type' => 'text', + }, + + { + 'key' => 'cust_main-enable_birthdate', + 'section' => 'UI', + 'descritpion' => 'Enable tracking of a birth date with each customer record', + 'type' => 'checkbox', + }, + + { + 'key' => 'support-key', + 'section' => '', + 'description' => 'A support key enables access to commercial services delivered over the network, such as the payroll module, access to the internal ticket system, priority support and optional backups.', + 'type' => 'text', + }, + + { + 'key' => 'card-types', + 'section' => 'billing', + 'description' => 'Select one or more card types to enable only those card types. If no card types are selected, all card types are available.', + 'type' => 'selectmultiple', + 'select_enum' => \@card_types, + }, + + { + 'key' => 'dashboard-toplist', + 'section' => 'UI', + 'description' => 'List of items to display on the top of the front page', + 'type' => 'textarea', + }, + + { + 'key' => 'impending_recur_template', + 'section' => 'billing', + 'description' => 'Template file for alerts about looming first time recurrant billing. See the <a href="http://search.cpan.org/~mjd/Text-Template.pm">Text::Template</a> documentation for details on the template substitition language. Also see packages with a <a href="../browse/part_pkg.cgi">flat price plan</a> The following variables are available<ul><li><code>$packages</code> allowing <code>$packages->[0]</code> thru <code>$packages->[n]</code> <li><code>$package</code> the first package, same as <code>$packages->[0]</code> <li><code>$recurdates</code> allowing <code>$recurdates->[0]</code> thru <code>$recurdates->[n]</code> <li><code>$recurdate</code> the first recurdate, same as <code>$recurdate->[0]</code> <li><code>$first</code> <li><code>$last</code></ul>', +# <li><code>$payby</code> <li><code>$expdate</code> most likely only confuse + 'type' => 'textarea', + }, + ); 1; diff --git a/FS/FS/ConfDefaults.pm b/FS/FS/ConfDefaults.pm new file mode 100644 index 000000000..baee0bb08 --- /dev/null +++ b/FS/FS/ConfDefaults.pm @@ -0,0 +1,68 @@ +package FS::ConfDefaults; + +=head1 NAME + +FS::ConfDefaults - Freeside configuration default and available values + +=head1 SYNOPSIS + + use FS::ConfDefaults; + + @avail_cust_fields = FS::ConfDefaults->cust_fields_avail(); + +=head1 DESCRIPTION + +Just a small class to keep config default and available values + +=head1 METHODS + +=over 4 + +=item cust_fields_avail + +Returns a list, suitable for assigning to a hash, of available values and +labels for customer fields values. + +=cut + +# XXX should use msgcat for "Day phone" and "Night phone", but how? +sub cust_fields_avail { ( + + 'Cust. Status | Customer' => + 'Status | Last, First or Company (Last, First)', + 'Cust# | Cust. Status | Customer' => + 'custnum | Status | Last, First or Company (Last, First)', + + 'Cust. Status | Name | Company' => + 'Status | Last, First | Company', + 'Cust# | Cust. Status | Name | Company' => + 'custnum | Status | Last, First | Company', + + 'Cust. Status | (bill) Customer | (service) Customer' => + 'Status | Last, First or Company (Last, First) | (same for service contact if present)', + 'Cust# | Cust. Status | (bill) Customer | (service) Customer' => + 'custnum | Status | Last, First or Company (Last, First) | (same for service contact if present)', + + 'Cust. Status | (bill) Name | (bill) Company | (service) Name | (service) Company' => + 'Status | Last, First | Company | (same for service address if present)', + 'Cust# | Cust. Status | (bill) Name | (bill) Company | (service) Name | (service) Company' => + 'custnum | Status | Last, First | Company | (same for service address if present)', + + 'Cust# | Cust. Status | Name | Company | Address 1 | Address 2 | City | State | Zip | Country | Day phone | Night phone | Invoicing email(s)' => + 'custnum | Status | Last, First | Company | (all address fields ) | Day phone | Night phone | Invoicing email(s)', + +); } + +=back + +=head1 BUGS + +Not yet. + +=head1 SEE ALSO + +L<FS::Conf> + +=cut + +1; diff --git a/FS/FS/Cron/backup.pm b/FS/FS/Cron/backup.pm new file mode 100644 index 000000000..204069a12 --- /dev/null +++ b/FS/FS/Cron/backup.pm @@ -0,0 +1,43 @@ +package FS::Cron::backup; + +use strict; +use vars qw( @ISA @EXPORT_OK ); +use Exporter; +use FS::UID qw(driver_name datasrc); + +@ISA = qw( Exporter ); +@EXPORT_OK = qw( backup_scp ); + +sub backup_scp { + my $conf = new FS::Conf; + my $dest = $conf->config('dump-scpdest'); + if ( $dest ) { + datasrc =~ /dbname=([\w\.]+)$/ or die "unparsable datasrc ". datasrc; + my $database = $1; + eval "use Net::SCP qw(scp);"; + die $@ if $@; + if ( driver_name eq 'Pg' ) { + system("pg_dump $database >/var/tmp/$database.sql") + } else { + die "database dumps not yet supported for ". driver_name; + } + if ( $conf->config('dump-pgpid') ) { + eval 'use GnuPG;'; + die $@ if $@; + my $gpg = new GnuPG; + $gpg->encrypt( plaintext => "/var/tmp/$database.sql", + output => "/var/tmp/$database.gpg", + recipient => $conf->config('dump-pgpid'), + ); + chmod 0600, '/var/tmp/$database.gpg'; + scp("/var/tmp/$database.gpg", $dest); + unlink "/var/tmp/$database.gpg" or die $!; + } else { + chmod 0600, '/var/tmp/$database.sql'; + scp("/var/tmp/$database.sql", $dest); + } + unlink "/var/tmp/$database.sql" or die $!; + } +} + +1; diff --git a/FS/FS/Cron/bill.pm b/FS/FS/Cron/bill.pm new file mode 100644 index 000000000..fb9e5499d --- /dev/null +++ b/FS/FS/Cron/bill.pm @@ -0,0 +1,118 @@ +package FS::Cron::bill; + +use strict; +use vars qw( @ISA @EXPORT_OK ); +use Exporter; +use Date::Parse; +use FS::Record qw(qsearch qsearchs); +use FS::cust_main; + +@ISA = qw( Exporter ); +@EXPORT_OK = qw ( bill ); + +sub bill { + + my %opt = @_; + + $FS::cust_main::DEBUG = 1 if $opt{'v'}; + + my %search = (); + $search{'payby'} = $opt{'p'} if $opt{'p'}; + $search{'agentnum'} = $opt{'a'} if $opt{'a'}; + + #we're at now now (and later). + my($time)= $opt{'d'} ? str2time($opt{'d'}) : $^T; + $time += $opt{'y'} * 86400 if $opt{'y'}; + + # select * from cust_main where + my $where_pkg = <<"END"; + 0 < ( select count(*) from cust_pkg + where cust_main.custnum = cust_pkg.custnum + and ( cancel is null or cancel = 0 ) + and ( setup is null or setup = 0 + or bill is null or bill <= $time + or ( expire is not null and expire <= $^T ) + ) + ) +END + + # or + my $where_bill_event = <<"END"; + 0 < ( select count(*) from cust_bill + where cust_main.custnum = cust_bill.custnum + and 0 < charged + - coalesce( + ( select sum(amount) from cust_bill_pay + where cust_bill.invnum = cust_bill_pay.invnum ) + ,0 + ) + - coalesce( + ( select sum(amount) from cust_credit_bill + where cust_bill.invnum = cust_credit_bill.invnum ) + ,0 + ) + and 0 < ( select count(*) from part_bill_event + where payby = cust_main.payby + and ( disabled is null or disabled = '' ) + and seconds <= $time - cust_bill._date + and 0 = ( select count(*) from cust_bill_event + where cust_bill.invnum = cust_bill_event.invnum + and part_bill_event.eventpart = cust_bill_event.eventpart + and status = 'done' + ) + + ) + ) +END + + my $extra_sql = ( scalar(%search) ? ' AND ' : ' WHERE ' ). "( $where_pkg OR $where_bill_event )"; + + my @cust_main; + if ( @ARGV ) { + @cust_main = map { qsearchs('cust_main', { custnum => $_, %search } ) } @ARGV + } else { + @cust_main = qsearch('cust_main', \%search, '', $extra_sql ); + } + ; + + my($cust_main,%saw); + foreach $cust_main ( @cust_main ) { + + # $^T not $time because -d is for pre-printing invoices + foreach my $cust_pkg ( + grep { $_->expire && $_->expire <= $^T } $cust_main->ncancelled_pkgs + ) { + my $error = $cust_pkg->cancel; + warn "Error cancelling expired pkg ". $cust_pkg->pkgnum. " for custnum ". + $cust_main->custnum. ": $error" + if $error; + } + # $^T not $time because -d is for pre-printing invoices + foreach my $cust_pkg ( + grep { $_->part_pkg->is_prepaid + && $_->bill && $_->bill < $^T && ! $_->susp + } + $cust_main->ncancelled_pkgs + ) { + my $error = $cust_pkg->suspend; + warn "Error suspending package ". $cust_pkg->pkgnum. + " for custnum ". $cust_main->custnum. + ": $error" + if $error; + } + + my $error = $cust_main->bill( 'time' => $time, + 'resetup' => $opt{'s'}, + ); + warn "Error billing, custnum ". $cust_main->custnum. ": $error" if $error; + + $cust_main->apply_payments_and_credits; + + $error = $cust_main->collect( 'invoice_time' => $time, + 'freq' => $opt{'freq'}, + ); + warn "Error collecting, custnum". $cust_main->custnum. ": $error" if $error; + + } + +} diff --git a/FS/FS/Cron/notify.pm b/FS/FS/Cron/notify.pm new file mode 100644 index 000000000..371065094 --- /dev/null +++ b/FS/FS/Cron/notify.pm @@ -0,0 +1,136 @@ +package FS::Cron::notify; + +use strict; +use vars qw( @ISA @EXPORT_OK $DEBUG ); +use Exporter; +use FS::UID qw( dbh ); +use FS::Record qw(qsearch); +use FS::cust_main; +use FS::cust_pkg; + +@ISA = qw( Exporter ); +@EXPORT_OK = qw ( notify_flat_delay ); +$DEBUG = 0; + +sub notify_flat_delay { + + my %opt = @_; + + my $oldAutoCommit = $FS::UID::AutoCommit; + $DEBUG = 1 if $opt{'v'}; + + #we're at now now (and later). + my($time) = $^T; + + # select * from cust_pkg where + my $where_pkg = <<"END"; + where ( cancel is null or cancel = 0 ) + and ( bill > 0 ) + and + 0 < ( select count(*) from part_pkg + where cust_pkg.pkgpart = part_pkg.pkgpart + and part_pkg.plan = 'flat_delayed' + and 0 < ( select count (*) from part_pkg_option + where part_pkg.pkgpart = part_pkg_option.pkgpart + and part_pkg_option.optionname = 'recur_notify' + and part_pkg_option.optionvalue > 0 + and 0 <= $time + + cast(part_pkg_option.optionvalue as integer) + * 86400 + - cust_pkg.bill + and ( cust_pkg.expire is null + or cust_pkg.expire > $time + + cast(part_pkg_option.optionvalue as integer) + * 86400 + ) + ) + ) + and + 0 = ( select count(*) from cust_pkg_option + where cust_pkg.pkgnum = cust_pkg_option.pkgnum + and cust_pkg_option.optionname = 'impending_recur_notification_sent' + and cust_pkg_option.optionvalue = 1 + ) +END + + if ($opt{a}) { + $where_pkg .= <<END; + and 0 < ( select count(*) from cust_main + where cust_pkg.custnum = cust_main.custnum + and cust_main.agentnum = $opt{a} + ) +END + } + + my @cust_pkg; + if ( @ARGV ) { + $where_pkg .= "and ( " . join( "OR ", map { "custnum = $_" } @ARGV) . " )"; + } + + my $orderby = "order by custnum, bill"; + + my $extra_sql = "$where_pkg $orderby"; + + @cust_pkg = qsearch('cust_pkg', {}, '', $extra_sql ); + + my @packages = (); + my @recurdates = (); + my @cust_pkgs = (); + while ( scalar(@cust_pkg) ) { + my $cust_main = $cust_pkg[0]->cust_main; + my $custnum = $cust_pkg[0]->custnum; + warn "working on $custnum" if $DEBUG; + while (scalar(@cust_pkg)){ + last if ($cust_pkg[0]->custnum != $custnum); + warn "storing information on " . $cust_pkg[0]->pkgnum if $DEBUG; + push @packages, $cust_pkg[0]->part_pkg->pkg; + push @recurdates, $cust_pkg[0]->bill; + push @cust_pkgs, $cust_pkg[0]; + shift @cust_pkg; + } + my $error = + $cust_main->notify( 'impending_recur_template', + 'extra_fields' => { 'packages' => \@packages, + 'recurdates' => \@recurdates, + 'package' => $packages[0], + 'recurdate' => $recurdates[0], + }, + ); + warn "Error notifying, custnum ". $cust_main->custnum. ": $error" if $error; + + unless ($error) { + local $SIG{HUP} = 'IGNORE'; + local $SIG{INT} = 'IGNORE'; + local $SIG{QUIT} = 'IGNORE'; + local $SIG{TERM} = 'IGNORE'; + local $SIG{TSTP} = 'IGNORE'; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + for (@cust_pkgs) { + my %options = ($_->options, 'impending_recur_notification_sent' => 1 ); + $error = $_->replace( $_, options => \%options ); + if ($error){ + $dbh->rollback or die $dbh->errstr if $oldAutoCommit; + die "Error updating package options for customer". $cust_main->custnum. + ": $error" if $error; + } + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + } + + @packages = (); + @recurdates = (); + @cust_pkgs = (); + + } + + dbh->commit or die dbh->errstr if $oldAutoCommit; + +} + +1; diff --git a/FS/FS/Cron/vacuum.pm b/FS/FS/Cron/vacuum.pm new file mode 100644 index 000000000..075572d50 --- /dev/null +++ b/FS/FS/Cron/vacuum.pm @@ -0,0 +1,23 @@ +package FS::Cron::vacuum; + +use vars qw( @ISA @EXPORT_OK); +use Exporter; +use FS::UID qw(driver_name dbh); +use FS::Schema qw(dbdef); + +@ISA = qw( Exporter ); +@EXPORT_OK = qw( vacuum ); + +sub vacuum { + + if ( driver_name eq 'Pg' ) { + dbh->{AutoCommit} = 1; #so we can vacuum + foreach my $table ( dbdef->tables ) { + my $sth = dbh->prepare("VACUUM ANALYZE $table") or die dbh->errstr; + $sth->execute or die $sth->errstr; + } + } + +} + +1; diff --git a/FS/FS/CurrentUser.pm b/FS/FS/CurrentUser.pm new file mode 100644 index 000000000..bcd337d2c --- /dev/null +++ b/FS/FS/CurrentUser.pm @@ -0,0 +1,67 @@ +package FS::CurrentUser; + +use vars qw($CurrentUser $upgrade_hack); + +#not at compile-time, circular dependancey causes trouble +#use FS::Record qw(qsearchs); +#use FS::access_user; + +$upgrade_hack = 0; + +=head1 NAME + +FS::CurrentUser - Package representing the current user + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=cut + +sub load_user { + my( $class, $user ) = @_; #, $pass + + if ( $upgrade_hack ) { + return $CurrentUser = new FS::CurrentUser::BootstrapUser; + } + + #return "" if $user =~ /^fs_(queue|selfservice)$/; + + #not the best thing in the world... + eval "use FS::Record qw(qsearchs);"; + die $@ if $@; + eval "use FS::access_user;"; + die $@ if $@; + + $CurrentUser = qsearchs('access_user', { + 'username' => $user, + #'_password' => + 'disabled' => '', + } ); + + die "unknown user: $user" unless $CurrentUser; # or bad password + + $CurrentUser; +} + +=head1 BUGS + +Creepy crawlies + +=head1 SEE ALSO + +=cut + +package FS::CurrentUser::BootstrapUser; + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + bless ($self, $class); +} + +sub AUTOLOAD { 1 }; + +1; + diff --git a/FS/FS/Daemon.pm b/FS/FS/Daemon.pm index 3e64f79e9..7e0d45c20 100644 --- a/FS/FS/Daemon.pm +++ b/FS/FS/Daemon.pm @@ -5,6 +5,7 @@ use vars qw( $pid_dir $me $pid_file $sigint $sigterm $logfile ); use Exporter; use Fcntl qw(:flock); use POSIX qw(setsid); +use IO::File; use Date::Format; #this is a simple refactoring of the stuff from freeside-queued, just to diff --git a/FS/FS/Misc.pm b/FS/FS/Misc.pm index 2e383d549..a535ecebf 100644 --- a/FS/FS/Misc.pm +++ b/FS/FS/Misc.pm @@ -7,7 +7,10 @@ use Carp; use Data::Dumper; @ISA = qw( Exporter ); -@EXPORT_OK = qw( send_email send_fax ); +@EXPORT_OK = qw( send_email send_fax + states_hash counties state_label + card_types + ); $DEBUG = 0; @@ -185,6 +188,80 @@ sub send_email { } +#this kludges a "mysmtpsend" method into Mail::Internet for send_email above +package Mail::Internet; + +use Mail::Address; +use Net::SMTP; + +sub Mail::Internet::mysmtpsend { + my $src = shift; + my %opt = @_; + my $host = $opt{Host}; + my $envelope = $opt{MailFrom}; + my $noquit = 0; + my $smtp; + my @hello = defined $opt{Hello} ? (Hello => $opt{Hello}) : (); + + push(@hello, 'Port', $opt{'Port'}) + if exists $opt{'Port'}; + + push(@hello, 'Debug', $opt{'Debug'}) + if exists $opt{'Debug'}; + + if(ref($host) && UNIVERSAL::isa($host,'Net::SMTP')) { + $smtp = $host; + $noquit = 1; + } + else { + #local $SIG{__DIE__}; + #$smtp = eval { Net::SMTP->new($host, @hello) }; + $smtp = new Net::SMTP $host, @hello; + } + + unless ( defined($smtp) ) { + my $err = $!; + $err =~ s/Invalid argument/Unknown host/; + return "can't connect to $host: $err" + } + + my $hdr = $src->head->dup; + + _prephdr($hdr); + + # Who is it to + + my @rcpt = map { ref($_) ? @$_ : $_ } grep { defined } @opt{'To','Cc','Bcc'}; + @rcpt = map { $hdr->get($_) } qw(To Cc Bcc) + unless @rcpt; + my @addr = map($_->address, Mail::Address->parse(@rcpt)); + + return 'No valid destination addresses found!' + unless(@addr); + + $hdr->delete('Bcc'); # Remove blind Cc's + + # Send it + + #warn "Headers: \n" . join('',@{$hdr->header}); + #warn "Body: \n" . join('',@{$src->body}); + + my $ok = $smtp->mail( $envelope ) && + $smtp->to(@addr) && + $smtp->data(join("", @{$hdr->header},"\n",@{$src->body})); + + if ( $ok ) { + $smtp->quit + unless $noquit; + return ''; + } else { + return $smtp->code. ' '. $smtp->message; + } + +} +package FS::Misc; +#eokludge + =item send_fax OPTION => VALUE ... Options: @@ -268,77 +345,128 @@ sub send_fax { } -package Mail::Internet; +=item states_hash COUNTRY -use Mail::Address; -use Net::SMTP; +Returns a list of key/value pairs containing state (or other sub-country +division) abbriviations and names. -sub Mail::Internet::mysmtpsend { - my $src = shift; - my %opt = @_; - my $host = $opt{Host}; - my $envelope = $opt{MailFrom}; - my $noquit = 0; - my $smtp; - my @hello = defined $opt{Hello} ? (Hello => $opt{Hello}) : (); +=cut - push(@hello, 'Port', $opt{'Port'}) - if exists $opt{'Port'}; +use FS::Record qw(qsearch); +use Locale::SubCountry; + +sub states_hash { + my($country) = @_; + + my @states = +# sort + map { s/[\n\r]//g; $_; } + map { $_->state; } + qsearch({ + 'select' => 'state', + 'table' => 'cust_main_county', + 'hashref' => { 'country' => $country }, + 'extra_sql' => 'GROUP BY state', + }); + + #it could throw a fatal "Invalid country code" error (for example "AX") + my $subcountry = eval { new Locale::SubCountry($country) } + or return ( '', '(n/a)' ); + + #"i see your schwartz is as big as mine!" + map { ( $_->[0] => $_->[1] ) } + sort { $a->[1] cmp $b->[1] } + map { [ $_ => state_label($_, $subcountry) ] } + @states; +} - push(@hello, 'Debug', $opt{'Debug'}) - if exists $opt{'Debug'}; +=item counties STATE COUNTRY - if(ref($host) && UNIVERSAL::isa($host,'Net::SMTP')) { - $smtp = $host; - $noquit = 1; - } - else { - #local $SIG{__DIE__}; - #$smtp = eval { Net::SMTP->new($host, @hello) }; - $smtp = new Net::SMTP $host, @hello; - } +Returns a list of counties for this state and country. - unless ( defined($smtp) ) { - my $err = $!; - $err =~ s/Invalid argument/Unknown host/; - return "can't connect to $host: $err" - } +=cut - my $hdr = $src->head->dup; +sub counties { + my( $state, $country ) = @_; + + sort map { s/[\n\r]//g; $_; } + map { $_->county } + qsearch({ + 'select' => 'DISTINCT county', + 'table' => 'cust_main_county', + 'hashref' => { 'state' => $state, + 'country' => $country, + }, + }); +} - _prephdr($hdr); +=item state_label STATE COUNTRY_OR_LOCALE_SUBCOUNRY_OBJECT - # Who is it to +=cut - my @rcpt = map { ref($_) ? @$_ : $_ } grep { defined } @opt{'To','Cc','Bcc'}; - @rcpt = map { $hdr->get($_) } qw(To Cc Bcc) - unless @rcpt; - my @addr = map($_->address, Mail::Address->parse(@rcpt)); +sub state_label { + my( $state, $country ) = @_; - return 'No valid destination addresses found!' - unless(@addr); + unless ( ref($country) ) { + $country = eval { new Locale::SubCountry($country) } + or return'(n/a)'; - $hdr->delete('Bcc'); # Remove blind Cc's + } - # Send it + # US kludge to avoid changing existing behaviour + # also we actually *use* the abbriviations... + my $full_name = $country->country_code eq 'US' + ? '' + : $country->full_name($state); - #warn "Headers: \n" . join('',@{$hdr->header}); - #warn "Body: \n" . join('',@{$src->body}); + $full_name = '' if $full_name eq 'unknown'; + $full_name =~ s/\(see also.*\)\s*$//; + $full_name .= " ($state)" if $full_name; - my $ok = $smtp->mail( $envelope ) && - $smtp->to(@addr) && - $smtp->data(join("", @{$hdr->header},"\n",@{$src->body})); + $full_name || $state || '(n/a)'; - if ( $ok ) { - $smtp->quit - unless $noquit; - return ''; - } else { - return $smtp->code. ' '. $smtp->message; - } +} +=item card_types + +Returns a hash reference of the accepted credit card types. Keys are shorter +identifiers and values are the longer strings used by the system (see +L<Business::CreditCard>). + +=cut + +#$conf from above + +sub card_types { + my $conf = new FS::Conf; + + my %card_types = ( + #displayname #value (Business::CreditCard) + "VISA" => "VISA card", + "MasterCard" => "MasterCard", + "Discover" => "Discover card", + "American Express" => "American Express card", + "Diner's Club/Carte Blanche" => "Diner's Club/Carte Blanche", + "enRoute" => "enRoute", + "JCB" => "JCB", + "BankCard" => "BankCard", + "Switch" => "Switch", + "Solo" => "Solo", + ); + my @conf_card_types = grep { ! /^\s*$/ } $conf->config('card-types'); + if ( @conf_card_types ) { + #perhaps the hash is backwards for this, but this way works better for + #usage in selfservice + %card_types = map { $_ => $card_types{$_} } + grep { + my $d = $_; + grep { $card_types{$d} eq $_ } @conf_card_types + } + keys %card_types; + } + + \%card_types; } -package FS::Misc; =back diff --git a/FS/FS/Pony.pm b/FS/FS/Pony.pm new file mode 100644 index 000000000..c37dd7855 --- /dev/null +++ b/FS/FS/Pony.pm @@ -0,0 +1,23 @@ +package FS::Pony; + +=head1 NAME + +FS::Pony - A pony + +=head1 SYNOPSYS + +use FS::Pony; # <-- yours! + +=head1 DESCRIPTION + +We told you it came with a pony. + +=head1 BUGS + +=head1 SEE ALSO + +http://420.am/~ivan/nopony.jpg + +=cut + +1; diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index 887c8dcd4..4efaeffdc 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -2,7 +2,8 @@ package FS::Record; use strict; use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG - $me %virtual_fields_cache $nowarn_identical ); + $conf $me + %virtual_fields_cache $nowarn_identical ); use Exporter; use Carp qw(carp cluck croak confess); use File::CounterFile; @@ -10,6 +11,7 @@ use Locale::Country; use DBI qw(:sql_types); use DBIx::DBSchema 0.25; use FS::UID qw(dbh getotaker datasrc driver_name); +use FS::CurrentUser; use FS::Schema qw(dbdef); use FS::SearchCache; use FS::Msgcat qw(gettext); @@ -29,7 +31,6 @@ $me = '[FS::Record]'; $nowarn_identical = 0; -my $conf; my $rsa_module; my $rsa_loaded; my $rsa_encrypt; @@ -37,9 +38,10 @@ my $rsa_decrypt; FS::UID->install_callback( sub { $conf = new FS::Conf; - $File::CounterFile::DEFAULT_DIR = "/usr/local/etc/freeside/counters.". datasrc; + $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc; } ); + =head1 NAME FS::Record - Database record objects @@ -82,8 +84,11 @@ FS::Record - Database record objects $value = $record->unique('column'); $error = $record->ut_float('column'); + $error = $record->ut_floatn('column'); $error = $record->ut_number('column'); $error = $record->ut_numbern('column'); + $error = $record->ut_snumber('column'); + $error = $record->ut_snumbern('column'); $error = $record->ut_money('column'); $error = $record->ut_text('column'); $error = $record->ut_textn('column'); @@ -250,7 +255,7 @@ sub qsearch { my $table = $cache ? $cache->table : $stable; my $dbdef_table = dbdef->table($table) or die "No schema for table $table found - ". - "do you need to create it or run dbdef-create?"; + "do you need to run freeside-upgrade?"; my $pkey = $dbdef_table->primary_key; my @real_fields = grep exists($record->{$_}), real_fields($table); @@ -285,7 +290,7 @@ sub qsearch { if ( $op eq '=' ) { if ( driver_name eq 'Pg' ) { my $type = dbdef->table($table)->column($column)->type; - if ( $type =~ /(int|serial)/i ) { + if ( $type =~ /(int|(big)?serial)/i ) { qq-( $column IS NULL )-; } else { qq-( $column IS NULL OR $column = '' )-; @@ -296,7 +301,7 @@ sub qsearch { } elsif ( $op eq '!=' ) { if ( driver_name eq 'Pg' ) { my $type = dbdef->table($table)->column($column)->type; - if ( $type =~ /(int|serial)/i ) { + if ( $type =~ /(int|(big)?serial)/i ) { qq-( $column IS NOT NULL )-; } else { qq-( $column IS NOT NULL AND $column != '' )-; @@ -365,7 +370,7 @@ sub qsearch { grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields ) { if ( $record->{$field} =~ /^\d+(\.\d+)?$/ - && dbdef->table($table)->column($field)->type =~ /(int|serial)/i + && dbdef->table($table)->column($field)->type =~ /(int|(big)?serial)/i ) { $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_INTEGER } ); } else { @@ -389,7 +394,7 @@ sub qsearch { my %result; tie %result, "Tie::IxHash"; my @stuff = @{ $sth->fetchall_arrayref( {} ) }; - if($pkey) { + if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) { %result = map { $_->{$pkey}, $_ } @stuff; } else { @result{@stuff} = @stuff; @@ -441,7 +446,11 @@ sub qsearch { } # Check for encrypted fields and decrypt them. - if ($conf->exists('encryption') && eval 'defined(@FS::'. $table . '::encrypted_fields)') { + ## only in the local copy, not the cached object + if ( $conf && $conf->exists('encryption') # $conf doesn't exist when doing + # the initial search for + # access_user + && eval 'defined(@FS::'. $table . '::encrypted_fields)') { foreach my $record (@return) { foreach my $field (eval '@FS::'. $table . '::encrypted_fields') { # Set it directly... This may cause a problem in the future... @@ -554,6 +563,17 @@ sub dbdef_table { dbdef->table($table); } +=item primary_key + +Returns the primary key for the table. + +=cut + +sub primary_key { + my $self = shift; + my $pkey = $self->dbdef_table->primary_key; +} + =item get, getfield COLUMN Returns the value of the column/field/key COLUMN. @@ -668,6 +688,24 @@ sub modified { $self->{'modified'}; } +=item select_for_update + +Selects this record with the SQL "FOR UPDATE" command. This can be useful as +a mutex. + +=cut + +sub select_for_update { + my $self = shift; + my $primary_key = $self->primary_key; + qsearchs( { + 'select' => '*', + 'table' => $self->table, + 'hashref' => { $primary_key => $self->$primary_key() }, + 'extra_sql' => 'FOR UPDATE', + } ); +} + =item insert Inserts this record to the database. If there is an error, returns the error, @@ -679,6 +717,8 @@ sub insert { my $self = shift; my $saved = {}; + warn "$self -> insert" if $DEBUG; + my $error = $self->check; return $error if $error; @@ -695,7 +735,7 @@ sub insert { my $col = $self->dbdef_table->column($primary_key); $db_seq = - uc($col->type) eq 'SERIAL' + uc($col->type) =~ /^(BIG)?SERIAL\d?/ || ( driver_name eq 'Pg' && defined($col->default) && $col->default =~ /^nextval\(/i @@ -711,28 +751,34 @@ sub insert { # Encrypt before the database - if ($conf->exists('encryption') && defined(eval '@FS::'. $table . 'encrypted_fields')) { + if ($conf->exists('encryption') && defined(eval '@FS::'. $table . '::encrypted_fields')) { foreach my $field (eval '@FS::'. $table . '::encrypted_fields') { $self->{'saved'} = $self->getfield($field); - $self->setfield($field, $self->enrypt($self->getfield($field))); + $self->setfield($field, $self->encrypt($self->getfield($field))); } } #false laziness w/delete my @real_fields = - grep defined($self->getfield($_)) && $self->getfield($_) ne "", + grep { defined($self->getfield($_)) && $self->getfield($_) ne "" } real_fields($table) ; my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields; #eslaf - my $statement = "INSERT INTO $table ( ". - join( ', ', @real_fields ). - ") VALUES (". - join( ', ', @values ). - ")" - ; + my $statement = "INSERT INTO $table "; + if ( @real_fields ) { + $statement .= + "( ". + join( ', ', @real_fields ). + ") VALUES (". + join( ', ', @values ). + ")" + ; + } else { + $statement .= 'DEFAULT VALUES'; + } warn "[debug]$me $statement\n" if $DEBUG > 1; my $sth = dbh->prepare($statement) or return dbh->errstr; @@ -757,7 +803,7 @@ sub insert { #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?"; my $default = $self->dbdef_table->column($primary_key)->default; - unless ( $default =~ /^nextval\('"?([\w\.]+)"?'/i ) { + unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) { dbh->rollback if $FS::UID::AutoCommit; return "can't parse $table.$primary_key default value". " for sequence name: $default"; @@ -769,8 +815,7 @@ sub insert { dbh->rollback if $FS::UID::AutoCommit; return dbh->errstr; }; - #$i_sth->execute($oid) or do { - $i_sth->execute() or do { + $i_sth->execute() or do { #$i_sth->execute($oid) dbh->rollback if $FS::UID::AutoCommit; return $i_sth->errstr; }; @@ -959,24 +1004,17 @@ returns the error, otherwise returns false. =cut sub replace { - my $new = shift; - my $old = shift; - - if (!defined($old)) { - warn "[debug]$me replace called with no arguments; autoloading old record\n" - if $DEBUG; - my $primary_key = $new->dbdef_table->primary_key; - if ( $primary_key ) { - $old = qsearchs($new->table, { $primary_key => $new->$primary_key() } ) - or croak "can't find ". $new->table. ".$primary_key ". - $new->$primary_key(); - } else { - croak $new->table. " has no primary key; pass old record as argument"; - } - } + my ($new, $old) = (shift, shift); + + $old = $new->replace_old unless defined($old); warn "[debug]$me $new ->replace $old\n" if $DEBUG; + if ( $new->can('replace_check') ) { + my $error = $new->replace_check($old); + return $error if $error; + } + return "Records not in same table!" unless $new->table eq $old->table; my $primary_key = $old->dbdef_table->primary_key; @@ -990,8 +1028,9 @@ sub replace { return $error if $error; # Encrypt for replace + my $conf = new FS::Conf; my $saved = {}; - if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . 'encrypted_fields')) { + if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . '::encrypted_fields')) { foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') { $saved->{$field} = $new->getfield($field); $new->setfield($field, $new->encrypt($new->getfield($field))); @@ -1021,7 +1060,7 @@ sub replace { #false laziness w/qsearch if ( driver_name eq 'Pg' ) { my $type = $old->dbdef_table->column($_)->type; - if ( $type =~ /(int|serial)/i ) { + if ( $type =~ /(int|(big)?serial)/i ) { qq-( $_ IS NULL )-; } else { qq-( $_ IS NULL OR $_ = '' )-; @@ -1137,6 +1176,22 @@ sub replace { } +sub replace_old { + my( $self ) = shift; + warn "[$me] replace called with no arguments; autoloading old record\n" + if $DEBUG; + + my $primary_key = $self->dbdef_table->primary_key; + if ( $primary_key ) { + $self->by_key( $self->$primary_key() ) #this is what's returned + or croak "can't find ". $self->table. ".$primary_key ". + $self->$primary_key(); + } else { + croak $self->table. " has no primary key; pass old record as argument"; + } + +} + =item rep Depriciated (use replace instead). @@ -1187,9 +1242,15 @@ sub _h_statement { $time ||= time; my @fields = - grep defined($self->getfield($_)) && $self->getfield($_) ne "", + grep { defined($self->getfield($_)) && $self->getfield($_) ne "" } real_fields($self->table); ; + + # If we're encrypting then don't ever store the payinfo or CVV2 in the history.... + # You can see if it changed by the paymask... + if ($conf->exists('encryption') ) { + @fields = grep $_ ne 'payinfo' && $_ ne 'cvv2', @fields; + } my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields; "INSERT INTO h_". $self->table. " ( ". @@ -1259,11 +1320,28 @@ sub ut_float { $self->setfield($field,$1); ''; } +=item ut_floatn COLUMN + +Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be +null. If there is an error, returns the error, otherwise returns false. + +=cut + +#false laziness w/ut_ipn +sub ut_floatn { + my( $self, $field ) = @_; + if ( $self->getfield($field) =~ /^()$/ ) { + $self->setfield($field,''); + ''; + } else { + $self->ut_float($field); + } +} =item ut_snumber COLUMN -Check/untaint signed numeric data (whole numbers). May not be null. If there -is an error, returns the error, otherwise returns false. +Check/untaint signed numeric data (whole numbers). If there is an error, +returns the error, otherwise returns false. =cut @@ -1275,6 +1353,25 @@ sub ut_snumber { ''; } +=item ut_snumbern COLUMN + +Check/untaint signed numeric data (whole numbers). If there is an error, +returns the error, otherwise returns false. + +=cut + +sub ut_snumbern { + my($self, $field) = @_; + $self->getfield($field) =~ /^(-?)\s*(\d*)$/ + or return "Illegal (numeric) $field: ". $self->getfield($field); + if ($1) { + return "Illegal (numeric) $field: ". $self->getfield($field) + unless $2; + } + $self->setfield($field, "$1$2"); + ''; +} + =item ut_number COLUMN Check/untaint simple numeric data (whole numbers). May not be null. If there @@ -1325,7 +1422,7 @@ sub ut_money { =item ut_text COLUMN Check/untaint text. Alphanumerics, spaces, and the following punctuation -symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = +symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] May not be null. If there is an error, returns the error, otherwise returns false. @@ -1336,9 +1433,10 @@ sub ut_text { #warn "msgcat ". \&msgcat. "\n"; #warn "notexist ". \¬exist. "\n"; #warn "AUTOLOAD ". \&AUTOLOAD. "\n"; - $self->getfield($field) =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=]+)$/ - or return gettext('illegal_or_empty_text'). " $field: ". - $self->getfield($field); + $self->getfield($field) + =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]+)$/ + or return gettext('illegal_or_empty_text'). " $field: ". + $self->getfield($field); $self->setfield($field,$1); ''; } @@ -1353,8 +1451,9 @@ May be null. If there is an error, returns the error, otherwise returns false. sub ut_textn { my($self,$field)=@_; - $self->getfield($field) =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=]*)$/ - or return gettext('illegal_text'). " $field: ". $self->getfield($field); + $self->getfield($field) + =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]*)$/ + or return gettext('illegal_text'). " $field: ". $self->getfield($field); $self->setfield($field,$1); ''; } @@ -1420,6 +1519,33 @@ sub ut_phonen { ''; } +=item ut_hex COLUMN + +Check/untaint hexadecimal values. + +=cut + +sub ut_hex { + my($self, $field) = @_; + $self->getfield($field) =~ /^([\da-fA-F]+)$/ + or return "Illegal (hex) $field: ". $self->getfield($field); + $self->setfield($field, uc($1)); + ''; +} + +=item ut_hexn COLUMN + +Check/untaint hexadecimal values. May be null. + +=cut + +sub ut_hexn { + my($self, $field) = @_; + $self->getfield($field) =~ /^([\da-fA-F]*)$/ + or return "Illegal (hex) $field: ". $self->getfield($field); + $self->setfield($field, uc($1)); + ''; +} =item ut_ip COLUMN Check/untaint ip addresses. IPv4 only for now. @@ -1489,16 +1615,27 @@ Check/untaint zip codes. =cut -my @zip_reqd_countries = qw( CA ); #US implicit... +my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit... sub ut_zip { my( $self, $field, $country ) = @_; + if ( $country eq 'US' ) { - $self->getfield($field) =~ /\s*(\d{5}(\-\d{4})?)\s*$/ + + $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/ + or return gettext('illegal_zip'). " $field for country $country: ". + $self->getfield($field); + $self->setfield($field, $1); + + } elsif ( $country eq 'CA' ) { + + $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i or return gettext('illegal_zip'). " $field for country $country: ". $self->getfield($field); - $self->setfield($field,$1); + $self->setfield($field, "$1 $2"); + } else { + if ( $self->getfield($field) =~ /^\s*$/ && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries ) ) @@ -1509,7 +1646,9 @@ sub ut_zip { or return gettext('illegal_zip'). " $field: ". $self->getfield($field); $self->setfield($field,$1); } + } + ''; } @@ -1593,6 +1732,36 @@ sub ut_foreign_keyn { : ''; } +=item ut_agentnum_acl + +Checks this column as an agentnum, taking into account the current users's +ACLs. + +=cut + +sub ut_agentnum_acl { + my( $self, $field, $null_acl ) = @_; + + my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum'); + return "Illegal agentnum: $error" if $error; + + my $curuser = $FS::CurrentUser::CurrentUser; + + if ( $self->$field() ) { + + return "Access deined" + unless $curuser->agentnum($self->$field()); + + } else { + + return "Access denied" + unless $curuser->access_right($null_acl); + + } + + ''; + +} =item virtual_fields [ TABLE ] @@ -1615,7 +1784,8 @@ sub virtual_fields { "WHERE dbtable = '$table'"; my $dbh = dbh; my $result = $dbh->selectcol_arrayref($query); - confess $dbh->errstr if $dbh->err; + confess "Error executing virtual fields query: $query: ". $dbh->errstr + if $dbh->err; $virtual_fields_cache{$table} = $result; } @@ -1699,14 +1869,12 @@ sub _quote { ( $nullable ? ' NULL' : ' NOT NULL' ). ")\n" if $DEBUG > 2; - if ( $value eq '' && $column_type =~ /^int/ ) { - if ( $nullable ) { - 'NULL'; - } else { - cluck "WARNING: Attempting to set non-null integer $table.$column null; ". - "using 0 instead"; - 0; - } + if ( $value eq '' && $nullable ) { + 'NULL' + } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) { + cluck "WARNING: Attempting to set non-null integer $table.$column null; ". + "using 0 instead"; + 0; } elsif ( $value =~ /^\d+(\.\d+)?$/ && ! $column_type =~ /(char|binary|text)$/i ) { $value; @@ -1764,10 +1932,22 @@ sub _dump { } (fields($self->table)) ); } +=item encrypt($value) + +Encrypts the credit card using a combination of PK to encrypt and uuencode to armour. + +Returns the encrypted string. + +You should generally not have to worry about calling this, as the system handles this for you. + +=cut + + sub encrypt { my ($self, $value) = @_; my $encrypted; + my $conf = new FS::Conf; if ($conf->exists('encryption')) { if ($self->is_encrypted($value)) { # Return the original value if it isn't plaintext. @@ -1787,25 +1967,42 @@ sub encrypt { return $encrypted; } +=item is_encrypted($value) + +Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status. + +=cut + + sub is_encrypted { my ($self, $value) = @_; # Possible Bug - Some work may be required here.... - if (length($value) > 80) { + if ($value =~ /^M/ && length($value) > 80) { return 1; } else { return 0; } } +=item decrypt($value) + +Uses the private key to decrypt the string. Returns the decryoted string or undef on failure. + +You should generally not have to worry about calling this, as the system handles this for you. + +=cut + sub decrypt { my ($self,$value) = @_; my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted. + my $conf = new FS::Conf; if ($conf->exists('encryption') && $self->is_encrypted($value)) { $self->loadRSA; if (ref($rsa_decrypt) =~ /::RSA/) { my $encrypted = unpack ("u*", $value); - $decrypted = unpack("Z*", $rsa_decrypt->decrypt($encrypted)); + $decrypted = unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)}); + if ($@) {warn "Decryption Failed"}; } } return $decrypted; @@ -1816,6 +2013,7 @@ sub loadRSA { #Initialize the Module $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default + my $conf = new FS::Conf; if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') { $rsa_module = $conf->config('encryptionmodule'); } diff --git a/FS/FS/Report/Table/Monthly.pm b/FS/FS/Report/Table/Monthly.pm index 89d44f92f..145f2a85c 100644 --- a/FS/FS/Report/Table/Monthly.pm +++ b/FS/FS/Report/Table/Monthly.pm @@ -5,6 +5,7 @@ use vars qw( @ISA $expenses_kludge ); use Time::Local; use FS::UID qw( dbh ); use FS::Report::Table; +use FS::CurrentUser; @ISA = qw( FS::Report::Table ); @@ -24,6 +25,11 @@ FS::Report::Table::Monthly - Tables of report data, indexed monthly 'start_year' => 2000, 'end_month' => 4, 'end_year' => 2020, + #opt + 'agentnum' => 54 + 'params' => [ [ 'paramsfor', 'item_one' ], [ 'item', 'two' ] ], # ... + 'remove_empty' => 1, #collapse empty rows, default 0 + 'item_labels' => [ ], #useful with remove_empty ); my $data = $report->data; @@ -41,10 +47,14 @@ Returns a hashref of data (!! describe) sub data { my $self = shift; + #use Data::Dumper; + #warn Dumper($self); + my $smonth = $self->{'start_month'}; my $syear = $self->{'start_year'}; my $emonth = $self->{'end_month'}; my $eyear = $self->{'end_year'}; + my $agentnum = $self->{'agentnum'}; my %data; @@ -58,64 +68,122 @@ sub data { my $eperiod = timelocal(0,0,0,1,$smonth-1,$syear); push @{$data{eperiod}}, $eperiod; + my $col = 0; + my @row = (); foreach my $item ( @{$self->{'items'}} ) { - push @{$data{$item}}, $self->$item($speriod, $eperiod); + my @param = $self->{'params'} ? @{ $self->{'params'}[$col] }: (); + my $value = $self->$item($speriod, $eperiod, $agentnum, @param); + #push @{$data{$item}}, $value; + push @{$data{data}->[$col++]}, $value; + } + + } + + #these need to get generalized, sheesh + $data{'items'} = $self->{'items'}; + $data{'item_labels'} = $self->{'item_labels'} || $self->{'items'}; + $data{'colors'} = $self->{'colors'}; + $data{'links'} = $self->{'links'} || []; + + #use Data::Dumper; + #warn Dumper(\%data); + + if ( $self->{'remove_empty'} ) { + + #warn "removing empty rows\n"; + + my $col = 0; + #these need to get generalized, sheesh + my @newitems = (); + my @newlabels = (); + my @newdata = (); + my @newcolors = (); + my @newlinks = (); + foreach my $item ( @{$self->{'items'}} ) { + + if ( grep { $_ != 0 } @{$data{'data'}->[$col]} ) { + push @newitems, $data{'items'}->[$col]; + push @newlabels, $data{'item_labels'}->[$col]; + push @newdata, $data{'data'}->[$col]; + push @newcolors, $data{'colors'}->[$col]; + push @newlinks, $data{'links'}->[$col]; + } + + $col++; } + $data{'items'} = \@newitems; + $data{'item_labels'} = \@newlabels; + $data{'data'} = \@newdata; + $data{'colors'} = \@newcolors; + $data{'links'} = \@newlinks; + } + #use Data::Dumper; + #warn Dumper(\%data); + \%data; } sub invoiced { #invoiced - my( $self, $speriod, $eperiod ) = ( shift, shift, shift ); + my( $self, $speriod, $eperiod, $agentnum ) = @_; + $self->scalar_sql(" - SELECT SUM(charged) FROM cust_bill - WHERE ". $self->in_time_period($speriod, $eperiod) + SELECT SUM(charged) + FROM cust_bill + LEFT JOIN cust_main USING ( custnum ) + WHERE ". $self->in_time_period_and_agent($speriod, $eperiod, $agentnum) ); + } sub netsales { #net sales - my( $self, $speriod, $eperiod ) = ( shift, shift, shift ); + my( $self, $speriod, $eperiod, $agentnum ) = @_; my $credited = $self->scalar_sql(" SELECT SUM(cust_credit_bill.amount) - FROM cust_credit_bill, cust_bill - WHERE cust_bill.invnum = cust_credit_bill.invnum - AND ". $self->in_time_period($speriod, $eperiod, 'cust_bill') + FROM cust_credit_bill + LEFT JOIN cust_bill USING ( invnum ) + LEFT JOIN cust_main USING ( custnum ) + WHERE ". $self->in_time_period_and_agent($speriod, $eperiod, $agentnum, 'cust_bill') ); #horrible local kludge my $expenses = !$expenses_kludge ? 0 : $self->scalar_sql(" SELECT SUM(cust_bill_pkg.setup) - FROM cust_bill_pkg, cust_bill, cust_pkg, part_pkg - WHERE cust_bill.invnum = cust_bill_pkg.invnum - AND ". $self->in_time_period($speriod, $eperiod, 'cust_bill'). " - AND cust_pkg.pkgnum = cust_bill_pkg.pkgnum - AND cust_pkg.pkgpart = part_pkg.pkgpart - AND LOWER(part_pkg.pkg) LIKE 'expense _%' + FROM cust_bill_pkg + LEFT JOIN cust_bill USING ( invnum ) + LEFT JOIN cust_main USING ( custnum ) + LEFT JOIN cust_pkg USING ( pkgnum ) + LEFT JOIN part_pkg USING ( pkgpart ) + WHERE ". $self->in_time_period_and_agent($speriod, $eperiod, $agentnum, 'cust_bill'). " + AND LOWER(part_pkg.pkg) LIKE 'expense _%' "); - $self->invoiced($speriod,$eperiod) - $credited - $expenses; + $self->invoiced($speriod,$eperiod,$agentnum) - $credited - $expenses; } #deferred revenue sub receipts { #cashflow - my( $self, $speriod, $eperiod ) = ( shift, shift, shift ); + my( $self, $speriod, $eperiod, $agentnum ) = @_; my $refunded = $self->scalar_sql(" - SELECT SUM(refund) FROM cust_refund - WHERE ". $self->in_time_period($speriod, $eperiod) + SELECT SUM(refund) + FROM cust_refund + LEFT JOIN cust_main USING ( custnum ) + WHERE ". $self->in_time_period_and_agent($speriod, $eperiod, $agentnum) ); #horrible local kludge that doesn't even really work right my $expenses = !$expenses_kludge ? 0 : $self->scalar_sql(" SELECT SUM(cust_bill_pay.amount) - FROM cust_bill_pay, cust_bill - WHERE cust_bill_pay.invnum = cust_bill.invnum - AND ". $self->in_time_period($speriod, $eperiod, 'cust_bill_pay'). " + FROM cust_bill_pay + LEFT JOIN cust_bill USING ( invnum ) + LEFT JOIN cust_main USING ( custnum ) + WHERE ". $self->in_time_period_and_agent($speriod, $eperiod, $agentnum, 'cust_bill_pay'). " AND 0 < ( SELECT COUNT(*) from cust_bill_pkg, cust_pkg, part_pkg WHERE cust_bill.invnum = cust_bill_pkg.invnum AND cust_pkg.pkgnum = cust_bill_pkg.pkgnum @@ -125,40 +193,117 @@ sub receipts { #cashflow "); # my $expenses_sql2 = "SELECT SUM(cust_bill_pay.amount) FROM cust_bill_pay, cust_bill_pkg, cust_bill, cust_pkg, part_pkg WHERE cust_bill_pay.invnum = cust_bill.invnum AND cust_bill.invnum = cust_bill_pkg.invnum AND cust_bill_pay._date >= $speriod AND cust_bill_pay._date < $eperiod AND cust_pkg.pkgnum = cust_bill_pkg.pkgnum AND cust_pkg.pkgpart = part_pkg.pkgpart AND LOWER(part_pkg.pkg) LIKE 'expense _%'"; - $self->payments($speriod, $eperiod) - $refunded - $expenses; + $self->payments($speriod, $eperiod, $agentnum) - $refunded - $expenses; } sub payments { - my( $self, $speriod, $eperiod ) = ( shift, shift, shift ); + my( $self, $speriod, $eperiod, $agentnum ) = @_; $self->scalar_sql(" - SELECT SUM(paid) FROM cust_pay - WHERE ". $self->in_time_period($speriod, $eperiod) + SELECT SUM(paid) + FROM cust_pay + LEFT JOIN cust_main USING ( custnum ) + WHERE ". $self->in_time_period_and_agent($speriod, $eperiod, $agentnum) ); } sub credits { - my( $self, $speriod, $eperiod ) = ( shift, shift, shift ); + my( $self, $speriod, $eperiod, $agentnum ) = @_; $self->scalar_sql(" - SELECT SUM(amount) FROM cust_credit - WHERE ". $self->in_time_period($speriod, $eperiod) + SELECT SUM(amount) + FROM cust_credit + LEFT JOIN cust_main USING ( custnum ) + WHERE ". $self->in_time_period_and_agent($speriod, $eperiod, $agentnum) ); } +#these should be auto-generated or $AUTOLOADed or something +sub invoiced_12mo { + my( $self, $speriod, $eperiod, $agentnum ) = @_; + $speriod = $self->_subtract_11mo($speriod); + $self->invoiced($speriod, $eperiod, $agentnum); +} + +sub netsales_12mo { + my( $self, $speriod, $eperiod, $agentnum ) = @_; + $speriod = $self->_subtract_11mo($speriod); + $self->netsales($speriod, $eperiod, $agentnum); +} + +sub receipts_12mo { + my( $self, $speriod, $eperiod, $agentnum ) = @_; + $speriod = $self->_subtract_11mo($speriod); + $self->receipts($speriod, $eperiod, $agentnum); +} + +sub payments_12mo { + my( $self, $speriod, $eperiod, $agentnum ) = @_; + $speriod = $self->_subtract_11mo($speriod); + $self->payments($speriod, $eperiod, $agentnum); +} + +sub credits_12mo { + my( $self, $speriod, $eperiod, $agentnum ) = @_; + $speriod = $self->_subtract_11mo($speriod); + $self->credits($speriod, $eperiod, $agentnum); +} + +#not being too bad with the false laziness +use Time::Local qw(timelocal); +sub _subtract_11mo { + my($self, $time) = @_; + my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($time) )[0,1,2,3,4,5]; + $mon -= 11; + if ( $mon < 0 ) { $mon+=12; $year--; } + timelocal($sec,$min,$hour,$mday,$mon,$year); +} + +sub cust_bill_pkg { + my( $self, $speriod, $eperiod, $agentnum, %opt ) = @_; + + my $where = ''; + if ( $opt{'classnum'} =~ /^(\d+)$/ ) { + if ( $1 == 0 ) { + $where = "classnum IS NULL"; + } else { + $where = "classnum = $1"; + } + } + + $agentnum ||= $opt{'agentnum'}; + + $self->scalar_sql(" + SELECT SUM(cust_bill_pkg.setup + cust_bill_pkg.recur) + FROM cust_bill_pkg + LEFT JOIN cust_bill USING ( invnum ) + LEFT JOIN cust_main USING ( custnum ) + LEFT JOIN cust_pkg USING ( pkgnum ) + LEFT JOIN part_pkg USING ( pkgpart ) + WHERE pkgnum != 0 + AND $where + AND ". $self->in_time_period_and_agent($speriod, $eperiod, $agentnum) + ); + +} + +# NEEDS TO BE AGENTNUM-capable sub canceled { #active - my( $self, $speriod, $eperiod ) = ( shift, shift, shift ); + my( $self, $speriod, $eperiod, $agentnum ) = @_; $self->scalar_sql(" - SELECT COUNT(*) FROM cust_pkg - WHERE cust_pkg.custnum = cust_main.custnum - AND 0 = ( SELECT COUNT(*) FROM cust_pkg - WHERE cust_pkg.custnum = cust_main.custnum - AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 ) - ) - AND cust_pkg.cancel > $speriod AND cust_pkg.cancel < $eperiod + SELECT COUNT(*) + FROM cust_pkg + LEFT JOIN cust_main USING ( custnum ) + WHERE 0 = ( SELECT COUNT(*) + FROM cust_pkg + WHERE cust_pkg.custnum = cust_main.custnum + AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 ) + ) + AND cust_pkg.cancel > $speriod AND cust_pkg.cancel < $eperiod "); } +# NEEDS TO BE AGENTNUM-capable sub newaccount { #newaccount - my( $self, $speriod, $eperiod ) = ( shift, shift, shift ); + my( $self, $speriod, $eperiod, $agentnum ) = @_; $self->scalar_sql(" SELECT COUNT(*) FROM cust_pkg WHERE cust_pkg.custnum = cust_main.custnum @@ -168,8 +313,9 @@ sub newaccount { #newaccount "); } +# NEEDS TO BE AGENTNUM-capable sub suspended { #suspended - my( $self, $speriod, $eperiod ) = ( shift, shift, shift ); + my( $self, $speriod, $eperiod, $agentnum ) = @_; $self->scalar_sql(" SELECT COUNT(*) FROM cust_pkg WHERE cust_pkg.custnum = cust_main.custnum @@ -182,10 +328,20 @@ sub suspended { #suspended "); } -sub in_time_period { - my( $self, $speriod, $eperiod ) = ( shift, shift, shift ); +sub in_time_period_and_agent { + my( $self, $speriod, $eperiod, $agentnum ) = splice(@_, 0, 4); my $table = @_ ? shift().'.' : ''; - "${table}_date >= $speriod AND ${table}_date < $eperiod"; + + my $sql = "${table}_date >= $speriod AND ${table}_date < $eperiod"; + + #agent selection + $sql .= " AND agentnum = $agentnum" + if $agentnum; + + #agent virtualization + $sql .= ' AND '. $FS::CurrentUser::CurrentUser->agentnums_sql; + + $sql; } sub scalar_sql { diff --git a/FS/FS/Schema.pm b/FS/FS/Schema.pm index 451ef2d2e..0d67834a0 100644 --- a/FS/FS/Schema.pm +++ b/FS/FS/Schema.pm @@ -3,9 +3,9 @@ package FS::Schema; use vars qw(@ISA @EXPORT_OK $DEBUG $setup_hack %dbdef_cache); use subs qw(reload_dbdef); use Exporter; -use DBIx::DBSchema 0.25; +use DBIx::DBSchema 0.30; use DBIx::DBSchema::Table; -use DBIx::DBSchema::Column; +use DBIx::DBSchema::Column 0.06; use DBIx::DBSchema::ColGroup::Unique; use DBIx::DBSchema::ColGroup::Index; use FS::UID qw(datasrc); @@ -16,13 +16,6 @@ use FS::UID qw(datasrc); $DEBUG = 0; $me = '[FS::Schema]'; -#ask FS::UID to run this stuff for us later -FS::UID->install_callback( sub { - #$conf = new FS::Conf; - &reload_dbdef("/usr/local/etc/freeside/dbdef.". datasrc) - unless $setup_hack; #$setup_hack needed now? -} ); - =head1 NAME FS::Schema - Freeside database schema @@ -58,7 +51,7 @@ sub reload_dbdef { unless ( exists $dbdef_cache{$file} ) { warn "[debug]$me loading dbdef for $file\n" if $DEBUG; $dbdef_cache{$file} = DBIx::DBSchema->load( $file ) - or die "can't load database schema from $file"; + or die "can't load database schema from $file: $DBIx::DBSchema::errstr\n"; } else { warn "[debug]$me re-using cached dbdef for $file\n" if $DEBUG; } @@ -92,9 +85,18 @@ sub dbdef_dist { my $dbdef = new DBIx::DBSchema map { my @columns; while (@{$tables_hashref->{$_}{'columns'}}) { - my($name, $type, $null, $length) = - splice @{$tables_hashref->{$_}{'columns'}}, 0, 4; - push @columns, new DBIx::DBSchema::Column ( $name,$type,$null,$length ); + #my($name, $type, $null, $length, $default, $local) = + my @coldef = + splice @{$tables_hashref->{$_}{'columns'}}, 0, 6; + my %hash = map { $_ => shift @coldef } + qw( name type null length default local ); + + unless ( defined $hash{'default'} ) { + warn "$_:\n". + join('', map "$_ => $hash{$_}\n", keys %hash) ;# $stop = <STDIN>; + } + + push @columns, new DBIx::DBSchema::Column ( \%hash ); } DBIx::DBSchema::Table->new( $_, @@ -235,19 +237,21 @@ sub tables_hashref { my $username_len = 32; #usernamemax config file + # name type nullability length default local + return { 'agent' => { 'columns' => [ - 'agentnum', 'serial', '', '', - 'agent', 'varchar', '', $char_d, - 'typenum', 'int', '', '', - 'freq', 'int', 'NULL', '', - 'prog', @perl_type, - 'disabled', 'char', 'NULL', 1, - 'username', 'varchar', 'NULL', $char_d, - '_password','varchar', 'NULL', $char_d, - 'ticketing_queueid', 'int', 'NULL', '', + 'agentnum', 'serial', '', '', '', '', + 'agent', 'varchar', '', $char_d, '', '', + 'typenum', 'int', '', '', '', '', + 'freq', 'int', 'NULL', '', '', '', + 'prog', @perl_type, '', '', + 'disabled', 'char', 'NULL', 1, '', '', + 'username', 'varchar', 'NULL', $char_d, '', '', + '_password','varchar', 'NULL', $char_d, '', '', + 'ticketing_queueid', 'int', 'NULL', '', '', '', ], 'primary_key' => 'agentnum', 'unique' => [], @@ -256,8 +260,8 @@ sub tables_hashref { 'agent_type' => { 'columns' => [ - 'typenum', 'serial', '', '', - 'atype', 'varchar', '', $char_d, + 'typenum', 'serial', '', '', '', '', + 'atype', 'varchar', '', $char_d, '', '', ], 'primary_key' => 'typenum', 'unique' => [], @@ -266,9 +270,9 @@ sub tables_hashref { 'type_pkgs' => { 'columns' => [ - 'typepkgnum', 'serial', '', '', - 'typenum', 'int', '', '', - 'pkgpart', 'int', '', '', + 'typepkgnum', 'serial', '', '', '', '', + 'typenum', 'int', '', '', '', '', + 'pkgpart', 'int', '', '', '', '', ], 'primary_key' => 'typepkgnum', 'unique' => [ ['typenum', 'pkgpart'] ], @@ -277,12 +281,12 @@ sub tables_hashref { 'cust_bill' => { 'columns' => [ - 'invnum', 'serial', '', '', - 'custnum', 'int', '', '', - '_date', @date_type, - 'charged', @money_type, - 'printed', 'int', '', '', - 'closed', 'char', 'NULL', 1, + 'invnum', 'serial', '', '', '', '', + 'custnum', 'int', '', '', '', '', + '_date', @date_type, '', '', + 'charged', @money_type, '', '', + 'printed', 'int', '', '', '', '', + 'closed', 'char', 'NULL', 1, '', '', ], 'primary_key' => 'invnum', 'unique' => [], @@ -291,12 +295,12 @@ sub tables_hashref { 'cust_bill_event' => { 'columns' => [ - 'eventnum', 'serial', '', '', - 'invnum', 'int', '', '', - 'eventpart', 'int', '', '', - '_date', @date_type, - 'status', 'varchar', '', $char_d, - 'statustext', 'text', 'NULL', '', + 'eventnum', 'serial', '', '', '', '', + 'invnum', 'int', '', '', '', '', + 'eventpart', 'int', '', '', '', '', + '_date', @date_type, '', '', + 'status', 'varchar', '', $char_d, '', '', + 'statustext', 'text', 'NULL', '', '', '', ], 'primary_key' => 'eventnum', #no... there are retries now #'unique' => [ [ 'eventpart', 'invnum' ] ], @@ -306,15 +310,17 @@ sub tables_hashref { 'part_bill_event' => { 'columns' => [ - 'eventpart', 'serial', '', '', - 'payby', 'char', '', 4, - 'event', 'varchar', '', $char_d, - 'eventcode', @perl_type, - 'seconds', 'int', 'NULL', '', - 'weight', 'int', '', '', - 'plan', 'varchar', 'NULL', $char_d, - 'plandata', 'text', 'NULL', '', - 'disabled', 'char', 'NULL', 1, + 'eventpart', 'serial', '', '', '', '', + 'freq', 'varchar', 'NULL', $char_d, '', '', + 'payby', 'char', '', 4, '', '', + 'event', 'varchar', '', $char_d, '', '', + 'eventcode', @perl_type, '', '', + 'seconds', 'int', 'NULL', '', '', '', + 'weight', 'int', '', '', '', '', + 'plan', 'varchar', 'NULL', $char_d, '', '', + 'plandata', 'text', 'NULL', '', '', '', + 'reason', 'int', 'NULL', '', '', '', + 'disabled', 'char', 'NULL', 1, '', '', ], 'primary_key' => 'eventpart', 'unique' => [], @@ -323,14 +329,14 @@ sub tables_hashref { 'cust_bill_pkg' => { 'columns' => [ - 'billpkgnum', 'serial', '', '', - 'pkgnum', 'int', '', '', - 'invnum', 'int', '', '', - 'setup', @money_type, - 'recur', @money_type, - 'sdate', @date_type, - 'edate', @date_type, - 'itemdesc', 'varchar', 'NULL', $char_d, + 'billpkgnum', 'serial', '', '', '', '', + 'pkgnum', 'int', '', '', '', '', + 'invnum', 'int', '', '', '', '', + 'setup', @money_type, '', '', + 'recur', @money_type, '', '', + 'sdate', @date_type, '', '', + 'edate', @date_type, '', '', + 'itemdesc', 'varchar', 'NULL', $char_d, '', '', ], 'primary_key' => 'billpkgnum', 'unique' => [], @@ -339,10 +345,10 @@ sub tables_hashref { 'cust_bill_pkg_detail' => { 'columns' => [ - 'detailnum', 'serial', '', '', - 'pkgnum', 'int', '', '', - 'invnum', 'int', '', '', - 'detail', 'varchar', '', $char_d, + 'detailnum', 'serial', '', '', '', '', + 'pkgnum', 'int', '', '', '', '', + 'invnum', 'int', '', '', '', '', + 'detail', 'varchar', '', $char_d, '', '', ], 'primary_key' => 'detailnum', 'unique' => [], @@ -351,13 +357,13 @@ sub tables_hashref { 'cust_credit' => { 'columns' => [ - 'crednum', 'serial', '', '', - 'custnum', 'int', '', '', - '_date', @date_type, - 'amount', @money_type, - 'otaker', 'varchar', '', 32, - 'reason', 'text', 'NULL', '', - 'closed', 'char', 'NULL', 1, + 'crednum', 'serial', '', '', '', '', + 'custnum', 'int', '', '', '', '', + '_date', @date_type, '', '', + 'amount', @money_type, '', '', + 'otaker', 'varchar', '', 32, '', '', + 'reason', 'text', 'NULL', '', '', '', + 'closed', 'char', 'NULL', 1, '', '', ], 'primary_key' => 'crednum', 'unique' => [], @@ -366,102 +372,137 @@ sub tables_hashref { 'cust_credit_bill' => { 'columns' => [ - 'creditbillnum', 'serial', '', '', - 'crednum', 'int', '', '', - 'invnum', 'int', '', '', - '_date', @date_type, - 'amount', @money_type, + 'creditbillnum', 'serial', '', '', '', '', + 'crednum', 'int', '', '', '', '', + 'invnum', 'int', '', '', '', '', + '_date', @date_type, '', '', + 'amount', @money_type, '', '', ], 'primary_key' => 'creditbillnum', 'unique' => [], 'index' => [ ['crednum'], ['invnum'] ], }, + 'cust_credit_bill_pkg' => { + 'columns' => [ + 'creditbillpkgnum', 'serial', '', '', '', '', + 'creditbillnum', 'int', '', '', '', '', + 'billpkgnum', 'int', '', '', '', '', + 'amount', @money_type, '', '', + 'setuprecur', 'varchar', '', $char_d, '', '', + 'sdate', @date_type, '', '', + 'edate', @date_type, '', '', + ], + 'primary_key' => 'creditbillpkgnum', + 'unique' => [], + 'index' => [ [ 'creditbillnum' ], [ 'billpkgnum' ], ], + }, + 'cust_main' => { 'columns' => [ - 'custnum', 'serial', '', '', - 'agentnum', 'int', '', '', -# 'titlenum', 'int', 'NULL', '', - 'last', 'varchar', '', $char_d, -# 'middle', 'varchar', 'NULL', $char_d, - 'first', 'varchar', '', $char_d, - 'ss', 'varchar', 'NULL', 11, - 'company', 'varchar', 'NULL', $char_d, - 'address1', 'varchar', '', $char_d, - 'address2', 'varchar', 'NULL', $char_d, - 'city', 'varchar', '', $char_d, - 'county', 'varchar', 'NULL', $char_d, - 'state', 'varchar', 'NULL', $char_d, - 'zip', 'varchar', 'NULL', 10, - 'country', 'char', '', 2, - 'daytime', 'varchar', 'NULL', 20, - 'night', 'varchar', 'NULL', 20, - 'fax', 'varchar', 'NULL', 12, - 'ship_last', 'varchar', 'NULL', $char_d, -# 'ship_middle', 'varchar', 'NULL', $char_d, - 'ship_first', 'varchar', 'NULL', $char_d, - 'ship_company', 'varchar', 'NULL', $char_d, - 'ship_address1', 'varchar', 'NULL', $char_d, - 'ship_address2', 'varchar', 'NULL', $char_d, - 'ship_city', 'varchar', 'NULL', $char_d, - 'ship_county', 'varchar', 'NULL', $char_d, - 'ship_state', 'varchar', 'NULL', $char_d, - 'ship_zip', 'varchar', 'NULL', 10, - 'ship_country', 'char', 'NULL', 2, - 'ship_daytime', 'varchar', 'NULL', 20, - 'ship_night', 'varchar', 'NULL', 20, - 'ship_fax', 'varchar', 'NULL', 12, - 'payby', 'char', '', 4, - 'payinfo', 'varchar', 'NULL', 512, - 'paycvv', 'varchar', 'NULL', 512, - 'paymask', 'varchar', 'NULL', $char_d, - #'paydate', @date_type, - 'paydate', 'varchar', 'NULL', 10, - 'paystart_month', 'int', 'NULL', '', - 'paystart_year', 'int', 'NULL', '', - 'payissue', 'varchar', 'NULL', 2, - 'payname', 'varchar', 'NULL', $char_d, - 'payip', 'varchar', 'NULL', 15, - 'tax', 'char', 'NULL', 1, - 'otaker', 'varchar', '', 32, - 'refnum', 'int', '', '', - 'referral_custnum', 'int', 'NULL', '', - 'comments', 'text', 'NULL', '', + 'custnum', 'serial', '', '', '', '', + 'agentnum', 'int', '', '', '', '', + 'agent_custid', 'varchar', 'NULL', $char_d, '', '', +# 'titlenum', 'int', 'NULL', '', '', '', + 'last', 'varchar', '', $char_d, '', '', +# 'middle', 'varchar', 'NULL', $char_d, '', '', + 'first', 'varchar', '', $char_d, '', '', + 'ss', 'varchar', 'NULL', 11, '', '', + 'birthdate' ,@date_type, '', '', + 'signupdate',@date_type, '', '', + 'company', 'varchar', 'NULL', $char_d, '', '', + 'address1', 'varchar', '', $char_d, '', '', + 'address2', 'varchar', 'NULL', $char_d, '', '', + 'city', 'varchar', '', $char_d, '', '', + 'county', 'varchar', 'NULL', $char_d, '', '', + 'state', 'varchar', 'NULL', $char_d, '', '', + 'zip', 'varchar', 'NULL', 10, '', '', + 'country', 'char', '', 2, '', '', + 'daytime', 'varchar', 'NULL', 20, '', '', + 'night', 'varchar', 'NULL', 20, '', '', + 'fax', 'varchar', 'NULL', 12, '', '', + 'ship_last', 'varchar', 'NULL', $char_d, '', '', +# 'ship_middle', 'varchar', 'NULL', $char_d, '', '', + 'ship_first', 'varchar', 'NULL', $char_d, '', '', + 'ship_company', 'varchar', 'NULL', $char_d, '', '', + 'ship_address1', 'varchar', 'NULL', $char_d, '', '', + 'ship_address2', 'varchar', 'NULL', $char_d, '', '', + 'ship_city', 'varchar', 'NULL', $char_d, '', '', + 'ship_county', 'varchar', 'NULL', $char_d, '', '', + 'ship_state', 'varchar', 'NULL', $char_d, '', '', + 'ship_zip', 'varchar', 'NULL', 10, '', '', + 'ship_country', 'char', 'NULL', 2, '', '', + 'ship_daytime', 'varchar', 'NULL', 20, '', '', + 'ship_night', 'varchar', 'NULL', 20, '', '', + 'ship_fax', 'varchar', 'NULL', 12, '', '', + 'payby', 'char', '', 4, '', '', + 'payinfo', 'varchar', 'NULL', 512, '', '', + 'paycvv', 'varchar', 'NULL', 512, '', '', + 'paymask', 'varchar', 'NULL', $char_d, '', '', + #'paydate', @date_type, '', '', + 'paydate', 'varchar', 'NULL', 10, '', '', + 'paystart_month', 'int', 'NULL', '', '', '', + 'paystart_year', 'int', 'NULL', '', '', '', + 'payissue', 'varchar', 'NULL', 2, '', '', + 'payname', 'varchar', 'NULL', $char_d, '', '', + 'payip', 'varchar', 'NULL', 15, '', '', + 'tax', 'char', 'NULL', 1, '', '', + 'otaker', 'varchar', '', 32, '', '', + 'refnum', 'int', '', '', '', '', + 'referral_custnum', 'int', 'NULL', '', '', '', + 'comments', 'text', 'NULL', '', '', '', + 'spool_cdr','char', 'NULL', 1, '', '', ], 'primary_key' => 'custnum', - 'unique' => [], + 'unique' => [ [ 'agentnum', 'agent_custid' ] ], #'index' => [ ['last'], ['company'] ], 'index' => [ ['last'], [ 'company' ], [ 'referral_custnum' ], [ 'daytime' ], [ 'night' ], [ 'fax' ], [ 'refnum' ], - [ 'county' ], [ 'state' ], [ 'country' ] + [ 'county' ], [ 'state' ], [ 'country' ], [ 'zip' ], + [ 'ship_last' ], [ 'ship_company' ], + [ 'payby' ], [ 'paydate' ], + ], }, 'cust_main_invoice' => { 'columns' => [ - 'destnum', 'serial', '', '', - 'custnum', 'int', '', '', - 'dest', 'varchar', '', $char_d, + 'destnum', 'serial', '', '', '', '', + 'custnum', 'int', '', '', '', '', + 'dest', 'varchar', '', $char_d, '', '', ], 'primary_key' => 'destnum', 'unique' => [], 'index' => [ ['custnum'], ], }, + 'cust_main_note' => { + 'columns' => [ + 'notenum', 'serial', '', '', '', '', + 'custnum', 'int', '', '', '', '', + '_date', @date_type, '', '', + 'otaker', 'varchar', '', 32, '', '', + 'comments', 'text', 'NULL', '', '', '', + ], + 'primary_key' => 'notenum', + 'unique' => [], + 'index' => [ [ 'custnum' ], [ '_date' ], ], + }, + 'cust_main_county' => { #county+state+country are checked off the #cust_main_county for validation and to provide # a tax rate. 'columns' => [ - 'taxnum', 'serial', '', '', - 'state', 'varchar', 'NULL', $char_d, - 'county', 'varchar', 'NULL', $char_d, - 'country', 'char', '', 2, - 'taxclass', 'varchar', 'NULL', $char_d, - 'exempt_amount', @money_type, - 'tax', 'real', '', '', #tax % - 'taxname', 'varchar', 'NULL', $char_d, - 'setuptax', 'char', 'NULL', 1, # Y = setup tax exempt - 'recurtax', 'char', 'NULL', 1, # Y = recur tax exempt + 'taxnum', 'serial', '', '', '', '', + 'state', 'varchar', 'NULL', $char_d, '', '', + 'county', 'varchar', 'NULL', $char_d, '', '', + 'country', 'char', '', 2, '', '', + 'taxclass', 'varchar', 'NULL', $char_d, '', '', + 'exempt_amount', @money_type, '', '', + 'tax', 'real', '', '', '', '', #tax % + 'taxname', 'varchar', 'NULL', $char_d, '', '', + 'setuptax', 'char', 'NULL', 1, '', '', # Y = setup tax exempt + 'recurtax', 'char', 'NULL', 1, '', '', # Y = recur tax exempt ], 'primary_key' => 'taxnum', 'unique' => [], @@ -471,16 +512,18 @@ sub tables_hashref { 'cust_pay' => { 'columns' => [ - 'paynum', 'serial', '', '', - #now cust_bill_pay #'invnum', 'int', '', '', - 'custnum', 'int', '', '', - 'paid', @money_type, - '_date', @date_type, - 'payby', 'char', '', 4, # CARD/BILL/COMP, should be index into - # payment type table. - 'payinfo', 'varchar', 'NULL', $char_d, #see cust_main above - 'paybatch', 'varchar', 'NULL', $char_d, #for auditing purposes. - 'closed', 'char', 'NULL', 1, + 'paynum', 'serial', '', '', '', '', + #now cust_bill_pay #'invnum', 'int', '', '', '', '', + 'custnum', 'int', '', '', '', '', + 'paid', @money_type, '', '', + '_date', @date_type, '', '', + 'payby', 'char', '', 4, '', '', # CARD/BILL/COMP, should be + # index into payby table + # eventually + 'payinfo', 'varchar', 'NULL', 512, '', '', #see cust_main above + 'paymask', 'varchar', 'NULL', $char_d, '', '', + 'paybatch', 'varchar', 'NULL', $char_d, '', '', #for auditing purposes. + 'closed', 'char', 'NULL', 1, '', '', ], 'primary_key' => 'paynum', 'unique' => [], @@ -489,18 +532,20 @@ sub tables_hashref { 'cust_pay_void' => { 'columns' => [ - 'paynum', 'int', '', '', - 'custnum', 'int', '', '', - 'paid', @money_type, - '_date', @date_type, - 'payby', 'char', '', 4, # CARD/BILL/COMP, should be index into - # payment type table. - 'payinfo', 'varchar', 'NULL', $char_d, #see cust_main above - 'paybatch', 'varchar', 'NULL', $char_d, #for auditing purposes. - 'closed', 'char', 'NULL', 1, - 'void_date', @date_type, - 'reason', 'varchar', 'NULL', $char_d, - 'otaker', 'varchar', '', 32, + 'paynum', 'int', '', '', '', '', + 'custnum', 'int', '', '', '', '', + 'paid', @money_type, '', '', + '_date', @date_type, '', '', + 'payby', 'char', '', 4, '', '', # CARD/BILL/COMP, should be + # index into payby table + # eventually + 'payinfo', 'varchar', 'NULL', 512, '', '', #see cust_main above + 'paymask', 'varchar', 'NULL', $char_d, '', '', + 'paybatch', 'varchar', 'NULL', $char_d, '', '', #for auditing purposes. + 'closed', 'char', 'NULL', 1, '', '', + 'void_date', @date_type, '', '', + 'reason', 'varchar', 'NULL', $char_d, '', '', + 'otaker', 'varchar', '', 32, '', '', ], 'primary_key' => 'paynum', 'unique' => [], @@ -509,76 +554,147 @@ sub tables_hashref { 'cust_bill_pay' => { 'columns' => [ - 'billpaynum', 'serial', '', '', - 'invnum', 'int', '', '', - 'paynum', 'int', '', '', - 'amount', @money_type, - '_date', @date_type + 'billpaynum', 'serial', '', '', '', '', + 'invnum', 'int', '', '', '', '', + 'paynum', 'int', '', '', '', '', + 'amount', @money_type, '', '', + '_date', @date_type, '', '', ], 'primary_key' => 'billpaynum', 'unique' => [], 'index' => [ [ 'paynum' ], [ 'invnum' ] ], }, + 'cust_bill_pay_batch' => { + 'columns' => [ + 'billpaynum', 'serial', '', '', '', '', + 'invnum', 'int', '', '', '', '', + 'paybatchnum', 'int', '', '', '', '', + 'amount', @money_type, '', '', + '_date', @date_type, '', '', + ], + 'primary_key' => 'billpaynum', + 'unique' => [], + 'index' => [ [ 'paybatchnum' ], [ 'invnum' ] ], + }, + + 'cust_bill_pay_pkg' => { + 'columns' => [ + 'billpaypkgnum', 'serial', '', '', '', '', + 'billpaynum', 'int', '', '', '', '', + 'billpkgnum', 'int', '', '', '', '', + 'amount', @money_type, '', '', + 'setuprecur', 'varchar', '', $char_d, '', '', + 'sdate', @date_type, '', '', + 'edate', @date_type, '', '', + ], + 'primary_key' => 'billpaypkgnum', + 'unique' => [], + 'index' => [ [ 'billpaynum' ], [ 'billpkgnum' ], ], + }, + + 'pay_batch' => { #batches of payments to an external processor + 'columns' => [ + 'batchnum', 'serial', '', '', '', '', + 'payby', 'char', '', 4, '', '', # CARD/CHEK + 'status', 'char', 'NULL', 1, '', '', + 'download', @date_type, '', '', + 'upload', @date_type, '', '', + ], + 'primary_key' => 'batchnum', + 'unique' => [], + 'index' => [], + }, + 'cust_pay_batch' => { #what's this used for again? list of customers #in current CARD batch? (necessarily CARD?) 'columns' => [ - 'paybatchnum', 'serial', '', '', - 'invnum', 'int', '', '', - 'custnum', 'int', '', '', - 'last', 'varchar', '', $char_d, - 'first', 'varchar', '', $char_d, - 'address1', 'varchar', '', $char_d, - 'address2', 'varchar', 'NULL', $char_d, - 'city', 'varchar', '', $char_d, - 'state', 'varchar', 'NULL', $char_d, - 'zip', 'varchar', 'NULL', 10, - 'country', 'char', '', 2, -# 'trancode', 'int', '', '', - 'cardnum', 'varchar', '', 16, - #'exp', @date_type, - 'exp', 'varchar', '', 11, - 'payname', 'varchar', 'NULL', $char_d, - 'amount', @money_type, + 'paybatchnum', 'serial', '', '', '', '', + 'batchnum', 'int', '', '', '', '', + 'invnum', 'int', '', '', '', '', + 'custnum', 'int', '', '', '', '', + 'last', 'varchar', '', $char_d, '', '', + 'first', 'varchar', '', $char_d, '', '', + 'address1', 'varchar', '', $char_d, '', '', + 'address2', 'varchar', 'NULL', $char_d, '', '', + 'city', 'varchar', '', $char_d, '', '', + 'state', 'varchar', 'NULL', $char_d, '', '', + 'zip', 'varchar', 'NULL', 10, '', '', + 'country', 'char', '', 2, '', '', + # 'trancode', 'int', '', '', '', '' + 'payby', 'char', '', 4, '', '', # CARD/BILL/COMP, should be + 'payinfo', 'varchar', '', 512, '', '', + #'exp', @date_type, '', '' + 'exp', 'varchar', 'NULL', 11, '', '', + 'payname', 'varchar', 'NULL', $char_d, '', '', + 'amount', @money_type, '', '', + 'status', 'varchar', 'NULL', $char_d, '', '', ], 'primary_key' => 'paybatchnum', 'unique' => [], - 'index' => [ ['invnum'], ['custnum'] ], + 'index' => [ ['batchnum'], ['invnum'], ['custnum'] ], }, 'cust_pkg' => { 'columns' => [ - 'pkgnum', 'serial', '', '', - 'custnum', 'int', '', '', - 'pkgpart', 'int', '', '', - 'otaker', 'varchar', '', 32, - 'setup', @date_type, - 'bill', @date_type, - 'last_bill', @date_type, - 'susp', @date_type, - 'cancel', @date_type, - 'expire', @date_type, - 'manual_flag', 'char', 'NULL', 1, + 'pkgnum', 'serial', '', '', '', '', + 'custnum', 'int', '', '', '', '', + 'pkgpart', 'int', '', '', '', '', + 'otaker', 'varchar', '', 32, '', '', + 'setup', @date_type, '', '', + 'bill', @date_type, '', '', + 'last_bill', @date_type, '', '', + 'susp', @date_type, '', '', + 'cancel', @date_type, '', '', + 'expire', @date_type, '', '', + 'manual_flag', 'char', 'NULL', 1, '', '', ], 'primary_key' => 'pkgnum', 'unique' => [], 'index' => [ ['custnum'], ['pkgpart'] ], }, + 'cust_pkg_option' => { + 'columns' => [ + 'optionnum', 'serial', '', '', '', '', + 'pkgnum', 'int', '', '', '', '', + 'optionname', 'varchar', '', $char_d, '', '', + 'optionvalue', 'text', 'NULL', '', '', '', + ], + 'primary_key' => 'optionnum', + 'unique' => [], + 'index' => [ [ 'pkgnum' ], [ 'optionname' ] ], + }, + + 'cust_pkg_reason' => { + 'columns' => [ + 'num', 'serial', '', '', '', '', + 'pkgnum', 'int', '', '', '', '', + 'reasonnum','int', '', '', '', '', + 'otaker', 'varchar', '', 32, '', '', + 'date', @date_type, '', '', + ], + 'primary_key' => 'num', + 'unique' => [], + 'index' => [], + }, + 'cust_refund' => { 'columns' => [ - 'refundnum', 'serial', '', '', - #now cust_credit_refund #'crednum', 'int', '', '', - 'custnum', 'int', '', '', - '_date', @date_type, - 'refund', @money_type, - 'otaker', 'varchar', '', 32, - 'reason', 'varchar', '', $char_d, - 'payby', 'char', '', 4, # CARD/BILL/COMP, should be index - # into payment type table. - 'payinfo', 'varchar', 'NULL', $char_d, #see cust_main above - 'paybatch', 'varchar', 'NULL', $char_d, - 'closed', 'char', 'NULL', 1, + 'refundnum', 'serial', '', '', '', '', + #now cust_credit_refund #'crednum', 'int', '', '', '', '', + 'custnum', 'int', '', '', '', '', + '_date', @date_type, '', '', + 'refund', @money_type, '', '', + 'otaker', 'varchar', '', 32, '', '', + 'reason', 'varchar', '', $char_d, '', '', + 'payby', 'char', '', 4, '', '', # CARD/BILL/COMP, should + # be index into payby + # table eventually + 'payinfo', 'varchar', 'NULL', 512, '', '', #see cust_main above + 'paymask', 'varchar', 'NULL', $char_d, '', '', + 'paybatch', 'varchar', 'NULL', $char_d, '', '', + 'closed', 'char', 'NULL', 1, '', '', ], 'primary_key' => 'refundnum', 'unique' => [], @@ -587,11 +703,11 @@ sub tables_hashref { 'cust_credit_refund' => { 'columns' => [ - 'creditrefundnum', 'serial', '', '', - 'crednum', 'int', '', '', - 'refundnum', 'int', '', '', - 'amount', @money_type, - '_date', @date_type + 'creditrefundnum', 'serial', '', '', '', '', + 'crednum', 'int', '', '', '', '', + 'refundnum', 'int', '', '', '', '', + 'amount', @money_type, '', '', + '_date', @date_type, '', '', ], 'primary_key' => 'creditrefundnum', 'unique' => [], @@ -601,9 +717,9 @@ sub tables_hashref { 'cust_svc' => { 'columns' => [ - 'svcnum', 'serial', '', '', - 'pkgnum', 'int', 'NULL', '', - 'svcpart', 'int', '', '', + 'svcnum', 'serial', '', '', '', '', + 'pkgnum', 'int', 'NULL', '', '', '', + 'svcpart', 'int', '', '', '', '', ], 'primary_key' => 'svcnum', 'unique' => [], @@ -612,19 +728,22 @@ sub tables_hashref { 'part_pkg' => { 'columns' => [ - 'pkgpart', 'serial', '', '', - 'pkg', 'varchar', '', $char_d, - 'comment', 'varchar', '', $char_d, - 'promo_code', 'varchar', 'NULL', $char_d, - 'setup', @perl_type, - 'freq', 'varchar', '', $char_d, #billing frequency - 'recur', @perl_type, - 'setuptax', 'char', 'NULL', 1, - 'recurtax', 'char', 'NULL', 1, - 'plan', 'varchar', 'NULL', $char_d, - 'plandata', 'text', 'NULL', '', - 'disabled', 'char', 'NULL', 1, - 'taxclass', 'varchar', 'NULL', $char_d, + 'pkgpart', 'serial', '', '', '', '', + 'pkg', 'varchar', '', $char_d, '', '', + 'comment', 'varchar', '', $char_d, '', '', + 'promo_code', 'varchar', 'NULL', $char_d, '', '', + 'setup', @perl_type, '', '', + 'freq', 'varchar', '', $char_d, '', '', #billing frequency + 'recur', @perl_type, '', '', + 'setuptax', 'char', 'NULL', 1, '', '', + 'recurtax', 'char', 'NULL', 1, '', '', + 'plan', 'varchar', 'NULL', $char_d, '', '', + 'plandata', 'text', 'NULL', '', '', '', + 'disabled', 'char', 'NULL', 1, '', '', + 'taxclass', 'varchar', 'NULL', $char_d, '', '', + 'classnum', 'int', 'NULL', '', '', '', + 'pay_weight', 'real', 'NULL', '', '', '', + 'credit_weight', 'real', 'NULL', '', '', '', ], 'primary_key' => 'pkgpart', 'unique' => [], @@ -643,11 +762,11 @@ sub tables_hashref { 'pkg_svc' => { 'columns' => [ - 'pkgsvcnum', 'serial', '', '', - 'pkgpart', 'int', '', '', - 'svcpart', 'int', '', '', - 'quantity', 'int', '', '', - 'primary_svc','char', 'NULL', 1, + 'pkgsvcnum', 'serial', '', '', '', '', + 'pkgpart', 'int', '', '', '', '', + 'svcpart', 'int', '', '', '', '', + 'quantity', 'int', '', '', '', '', + 'primary_svc','char', 'NULL', 1, '', '', ], 'primary_key' => 'pkgsvcnum', 'unique' => [ ['pkgpart', 'svcpart'] ], @@ -656,9 +775,10 @@ sub tables_hashref { 'part_referral' => { 'columns' => [ - 'refnum', 'serial', '', '', - 'referral', 'varchar', '', $char_d, - 'disabled', 'char', 'NULL', 1, + 'refnum', 'serial', '', '', '', '', + 'referral', 'varchar', '', $char_d, '', '', + 'disabled', 'char', 'NULL', 1, '', '', + 'agentnum', 'int', 'NULL', '', '', '', ], 'primary_key' => 'refnum', 'unique' => [], @@ -667,10 +787,10 @@ sub tables_hashref { 'part_svc' => { 'columns' => [ - 'svcpart', 'serial', '', '', - 'svc', 'varchar', '', $char_d, - 'svcdb', 'varchar', '', $char_d, - 'disabled', 'char', 'NULL', 1, + 'svcpart', 'serial', '', '', '', '', + 'svc', 'varchar', '', $char_d, '', '', + 'svcdb', 'varchar', '', $char_d, '', '', + 'disabled', 'char', 'NULL', 1, '', '', ], 'primary_key' => 'svcpart', 'unique' => [], @@ -679,11 +799,11 @@ sub tables_hashref { 'part_svc_column' => { 'columns' => [ - 'columnnum', 'serial', '', '', - 'svcpart', 'int', '', '', - 'columnname', 'varchar', '', 64, - 'columnvalue', 'varchar', 'NULL', $char_d, - 'columnflag', 'char', 'NULL', 1, + 'columnnum', 'serial', '', '', '', '', + 'svcpart', 'int', '', '', '', '', + 'columnname', 'varchar', '', 64, '', '', + 'columnvalue', 'varchar', 'NULL', $char_d, '', '', + 'columnflag', 'char', 'NULL', 1, '', '', ], 'primary_key' => 'columnnum', 'unique' => [ [ 'svcpart', 'columnname' ] ], @@ -693,12 +813,12 @@ sub tables_hashref { #(this should be renamed to part_pop) 'svc_acct_pop' => { 'columns' => [ - 'popnum', 'serial', '', '', - 'city', 'varchar', '', $char_d, - 'state', 'varchar', '', $char_d, - 'ac', 'char', '', 3, - 'exch', 'char', '', 3, - 'loc', 'char', 'NULL', 4, #NULL for legacy purposes + 'popnum', 'serial', '', '', '', '', + 'city', 'varchar', '', $char_d, '', '', + 'state', 'varchar', '', $char_d, '', '', + 'ac', 'char', '', 3, '', '', + 'exch', 'char', '', 3, '', '', + 'loc', 'char', 'NULL', 4, '', '', #NULL for legacy purposes ], 'primary_key' => 'popnum', 'unique' => [], @@ -707,12 +827,12 @@ sub tables_hashref { 'part_pop_local' => { 'columns' => [ - 'localnum', 'serial', '', '', - 'popnum', 'int', '', '', - 'city', 'varchar', 'NULL', $char_d, - 'state', 'char', 'NULL', 2, - 'npa', 'char', '', 3, - 'nxx', 'char', '', 3, + 'localnum', 'serial', '', '', '', '', + 'popnum', 'int', '', '', '', '', + 'city', 'varchar', 'NULL', $char_d, '', '', + 'state', 'char', 'NULL', 2, '', '', + 'npa', 'char', '', 3, '', '', + 'nxx', 'char', '', 3, '', '', ], 'primary_key' => 'localnum', 'unique' => [], @@ -721,20 +841,27 @@ sub tables_hashref { 'svc_acct' => { 'columns' => [ - 'svcnum', 'int', '', '', - 'username', 'varchar', '', $username_len, #unique (& remove dup code) - '_password', 'varchar', '', 72, #13 for encryped pw's plus ' *SUSPENDED* (md5 passwords can be 34, blowfish 60) - 'sec_phrase', 'varchar', 'NULL', $char_d, - 'popnum', 'int', 'NULL', '', - 'uid', 'int', 'NULL', '', - 'gid', 'int', 'NULL', '', - 'finger', 'varchar', 'NULL', $char_d, - 'dir', 'varchar', 'NULL', $char_d, - 'shell', 'varchar', 'NULL', $char_d, - 'quota', 'varchar', 'NULL', $char_d, - 'slipip', 'varchar', 'NULL', 15, #four TINYINTs, bah. - 'seconds', 'int', 'NULL', '', #uhhhh - 'domsvc', 'int', '', '', + 'svcnum', 'int', '', '', '', '', + 'username', 'varchar', '', $username_len, '', '', #unique (& remove dup code) + '_password', 'varchar', '', 72, '', '', #13 for encryped pw's plus ' *SUSPENDED* (md5 passwords can be 34, blowfish 60) + 'sec_phrase', 'varchar', 'NULL', $char_d, '', '', + 'popnum', 'int', 'NULL', '', '', '', + 'uid', 'int', 'NULL', '', '', '', + 'gid', 'int', 'NULL', '', '', '', + 'finger', 'varchar', 'NULL', $char_d, '', '', + 'dir', 'varchar', 'NULL', $char_d, '', '', + 'shell', 'varchar', 'NULL', $char_d, '', '', + 'quota', 'varchar', 'NULL', $char_d, '', '', + 'slipip', 'varchar', 'NULL', 15, '', '', #four TINYINTs, bah. + 'seconds', 'int', 'NULL', '', '', '', #uhhhh + 'seconds_threshold', 'int', 'NULL', '', '', '', + 'upbytes', 'bigint', 'NULL', '', '', '', + 'upbytes_threshold', 'bigint', 'NULL', '', '', '', + 'downbytes', 'bigint', 'NULL', '', '', '', + 'downbytes_threshold', 'bigint', 'NULL', '', '', '', + 'totalbytes','bigint', 'NULL', '', '', '', + 'totalbytes_threshold', 'bigint', 'NULL', '', '', '', + 'domsvc', 'int', '', '', '', '', ], 'primary_key' => 'svcnum', #'unique' => [ [ 'username', 'domsvc' ] ], @@ -754,38 +881,53 @@ sub tables_hashref { 'svc_domain' => { 'columns' => [ - 'svcnum', 'int', '', '', - 'domain', 'varchar', '', $char_d, - 'catchall', 'int', 'NULL', '', + 'svcnum', 'int', '', '', '', '', + 'domain', 'varchar', '', $char_d, '', '', + 'suffix', 'varchar', 'NULL', $char_d, '', '', + 'catchall', 'int', 'NULL', '', '', '', + 'parent_svcnum', 'int', 'NULL', '', '', '', + 'registrarnum', 'int', 'NULL', '', '', '', + 'registrarkey', 'varchar', 'NULL', '', '', '', + 'setup_date', @date_type, '', '', + 'renewal_interval', 'int', 'NULL', '', '', '', + 'expiration_date', @date_type, '', '', ], 'primary_key' => 'svcnum', - 'unique' => [ ['domain'] ], - 'index' => [], + 'unique' => [ ], + 'index' => [ ['domain'] ], }, 'domain_record' => { 'columns' => [ - 'recnum', 'serial', '', '', - 'svcnum', 'int', '', '', - #'reczone', 'varchar', '', $char_d, - 'reczone', 'varchar', '', 255, - 'recaf', 'char', '', 2, - 'rectype', 'varchar', '', 5, - #'recdata', 'varchar', '', $char_d, - 'recdata', 'varchar', '', 255, + 'recnum', 'serial', '', '', '', '', + 'svcnum', 'int', '', '', '', '', + 'reczone', 'varchar', '', 255, '', '', + 'recaf', 'char', '', 2, '', '', + 'rectype', 'varchar', '', 5, '', '', + 'recdata', 'varchar', '', 255, '', '', ], 'primary_key' => 'recnum', 'unique' => [], 'index' => [ ['svcnum'] ], }, + 'registrar' => { + 'columns' => [ + 'registrarnum', 'serial', '', '', '', '', + 'registrarname', 'varchar', '', $char_d, '', '', + ], + 'primary_key' => 'registrarnum', + 'unique' => [], + 'index' => [], + }, + 'svc_forward' => { 'columns' => [ - 'svcnum', 'int', '', '', - 'srcsvc', 'int', 'NULL', '', - 'src', 'varchar', 'NULL', 255, - 'dstsvc', 'int', 'NULL', '', - 'dst', 'varchar', 'NULL', 255, + 'svcnum', 'int', '', '', '', '', + 'srcsvc', 'int', 'NULL', '', '', '', + 'src', 'varchar', 'NULL', 255, '', '', + 'dstsvc', 'int', 'NULL', '', '', '', + 'dst', 'varchar', 'NULL', 255, '', '', ], 'primary_key' => 'svcnum', 'unique' => [], @@ -794,9 +936,9 @@ sub tables_hashref { 'svc_www' => { 'columns' => [ - 'svcnum', 'int', '', '', - 'recnum', 'int', '', '', - 'usersvc', 'int', '', '', + 'svcnum', 'int', '', '', '', '', + 'recnum', 'int', '', '', '', '', + 'usersvc', 'int', '', '', '', '', ], 'primary_key' => 'svcnum', 'unique' => [], @@ -818,11 +960,14 @@ sub tables_hashref { 'prepay_credit' => { 'columns' => [ - 'prepaynum', 'serial', '', '', - 'identifier', 'varchar', '', $char_d, - 'amount', @money_type, - 'seconds', 'int', 'NULL', '', - 'agentnum', 'int', 'NULL', '', + 'prepaynum', 'serial', '', '', '', '', + 'identifier', 'varchar', '', $char_d, '', '', + 'amount', @money_type, '', '', + 'seconds', 'int', 'NULL', '', '', '', + 'upbytes', 'bigint', 'NULL', '', '', '', + 'downbytes', 'bigint', 'NULL', '', '', '', + 'totalbytes', 'bigint', 'NULL', '', '', '', + 'agentnum', 'int', 'NULL', '', '', '', ], 'primary_key' => 'prepaynum', 'unique' => [ ['identifier'] ], @@ -831,10 +976,10 @@ sub tables_hashref { 'port' => { 'columns' => [ - 'portnum', 'serial', '', '', - 'ip', 'varchar', 'NULL', 15, - 'nasport', 'int', 'NULL', '', - 'nasnum', 'int', '', '', + 'portnum', 'serial', '', '', '', '', + 'ip', 'varchar', 'NULL', 15, '', '', + 'nasport', 'int', 'NULL', '', '', '', + 'nasnum', 'int', '', '', '', '', ], 'primary_key' => 'portnum', 'unique' => [], @@ -843,11 +988,11 @@ sub tables_hashref { 'nas' => { 'columns' => [ - 'nasnum', 'serial', '', '', - 'nas', 'varchar', '', $char_d, - 'nasip', 'varchar', '', 15, - 'nasfqdn', 'varchar', '', $char_d, - 'last', 'int', '', '', + 'nasnum', 'serial', '', '', '', '', + 'nas', 'varchar', '', $char_d, '', '', + 'nasip', 'varchar', '', 15, '', '', + 'nasfqdn', 'varchar', '', $char_d, '', '', + 'last', 'int', '', '', '', '', ], 'primary_key' => 'nasnum', 'unique' => [ [ 'nas' ], [ 'nasip' ] ], @@ -856,11 +1001,11 @@ sub tables_hashref { 'session' => { 'columns' => [ - 'sessionnum', 'serial', '', '', - 'portnum', 'int', '', '', - 'svcnum', 'int', '', '', - 'login', @date_type, - 'logout', @date_type, + 'sessionnum', 'serial', '', '', '', '', + 'portnum', 'int', '', '', '', '', + 'svcnum', 'int', '', '', '', '', + 'login', @date_type, '', '', + 'logout', @date_type, '', '', ], 'primary_key' => 'sessionnum', 'unique' => [], @@ -869,12 +1014,12 @@ sub tables_hashref { 'queue' => { 'columns' => [ - 'jobnum', 'serial', '', '', - 'job', 'text', '', '', - '_date', 'int', '', '', - 'status', 'varchar', '', $char_d, - 'statustext', 'text', 'NULL', '', - 'svcnum', 'int', 'NULL', '', + 'jobnum', 'serial', '', '', '', '', + 'job', 'text', '', '', '', '', + '_date', 'int', '', '', '', '', + 'status', 'varchar', '', $char_d, '', '', + 'statustext', 'text', 'NULL', '', '', '', + 'svcnum', 'int', 'NULL', '', '', '', ], 'primary_key' => 'jobnum', 'unique' => [], @@ -883,9 +1028,9 @@ sub tables_hashref { 'queue_arg' => { 'columns' => [ - 'argnum', 'serial', '', '', - 'jobnum', 'int', '', '', - 'arg', 'text', 'NULL', '', + 'argnum', 'serial', '', '', '', '', + 'jobnum', 'int', '', '', '', '', + 'arg', 'text', 'NULL', '', '', '', ], 'primary_key' => 'argnum', 'unique' => [], @@ -894,9 +1039,9 @@ sub tables_hashref { 'queue_depend' => { 'columns' => [ - 'dependnum', 'serial', '', '', - 'jobnum', 'int', '', '', - 'depend_jobnum', 'int', '', '', + 'dependnum', 'serial', '', '', '', '', + 'jobnum', 'int', '', '', '', '', + 'depend_jobnum', 'int', '', '', '', '', ], 'primary_key' => 'dependnum', 'unique' => [], @@ -905,9 +1050,9 @@ sub tables_hashref { 'export_svc' => { 'columns' => [ - 'exportsvcnum' => 'serial', '', '', - 'exportnum' => 'int', '', '', - 'svcpart' => 'int', '', '', + 'exportsvcnum' => 'serial', '', '', '', '', + 'exportnum' => 'int', '', '', '', '', + 'svcpart' => 'int', '', '', '', '', ], 'primary_key' => 'exportsvcnum', 'unique' => [ [ 'exportnum', 'svcpart' ] ], @@ -916,11 +1061,10 @@ sub tables_hashref { 'part_export' => { 'columns' => [ - 'exportnum', 'serial', '', '', - #'svcpart', 'int', '', '', - 'machine', 'varchar', '', $char_d, - 'exporttype', 'varchar', '', $char_d, - 'nodomain', 'char', 'NULL', 1, + 'exportnum', 'serial', '', '', '', '', + 'machine', 'varchar', '', $char_d, '', '', + 'exporttype', 'varchar', '', $char_d, '', '', + 'nodomain', 'char', 'NULL', 1, '', '', ], 'primary_key' => 'exportnum', 'unique' => [], @@ -929,10 +1073,10 @@ sub tables_hashref { 'part_export_option' => { 'columns' => [ - 'optionnum', 'serial', '', '', - 'exportnum', 'int', '', '', - 'optionname', 'varchar', '', $char_d, - 'optionvalue', 'text', 'NULL', '', + 'optionnum', 'serial', '', '', '', '', + 'exportnum', 'int', '', '', '', '', + 'optionname', 'varchar', '', $char_d, '', '', + 'optionvalue', 'text', 'NULL', '', '', '', ], 'primary_key' => 'optionnum', 'unique' => [], @@ -941,9 +1085,9 @@ sub tables_hashref { 'radius_usergroup' => { 'columns' => [ - 'usergroupnum', 'serial', '', '', - 'svcnum', 'int', '', '', - 'groupname', 'varchar', '', $char_d, + 'usergroupnum', 'serial', '', '', '', '', + 'svcnum', 'int', '', '', '', '', + 'groupname', 'varchar', '', $char_d, '', '', ], 'primary_key' => 'usergroupnum', 'unique' => [], @@ -952,10 +1096,10 @@ sub tables_hashref { 'msgcat' => { 'columns' => [ - 'msgnum', 'serial', '', '', - 'msgcode', 'varchar', '', $char_d, - 'locale', 'varchar', '', 16, - 'msg', 'text', '', '', + 'msgnum', 'serial', '', '', '', '', + 'msgcode', 'varchar', '', $char_d, '', '', + 'locale', 'varchar', '', 16, '', '', + 'msg', 'text', '', '', '', '', ], 'primary_key' => 'msgnum', 'unique' => [ [ 'msgcode', 'locale' ] ], @@ -964,23 +1108,41 @@ sub tables_hashref { 'cust_tax_exempt' => { 'columns' => [ - 'exemptnum', 'serial', '', '', - 'custnum', 'int', '', '', - 'taxnum', 'int', '', '', - 'year', 'int', '', '', - 'month', 'int', '', '', - 'amount', @money_type, + 'exemptnum', 'serial', '', '', '', '', + 'custnum', 'int', '', '', '', '', + 'taxnum', 'int', '', '', '', '', + 'year', 'int', '', '', '', '', + 'month', 'int', '', '', '', '', + 'amount', @money_type, '', '', ], 'primary_key' => 'exemptnum', 'unique' => [ [ 'custnum', 'taxnum', 'year', 'month' ] ], 'index' => [], }, + 'cust_tax_exempt_pkg' => { + 'columns' => [ + 'exemptpkgnum', 'serial', '', '', '', '', + #'custnum', 'int', '', '', '', '' + 'billpkgnum', 'int', '', '', '', '', + 'taxnum', 'int', '', '', '', '', + 'year', 'int', '', '', '', '', + 'month', 'int', '', '', '', '', + 'amount', @money_type, '', '', + ], + 'primary_key' => 'exemptpkgnum', + 'unique' => [], + 'index' => [ [ 'taxnum', 'year', 'month' ], + [ 'billpkgnum' ], + [ 'taxnum' ] + ], + }, + 'router' => { 'columns' => [ - 'routernum', 'serial', '', '', - 'routername', 'varchar', '', $char_d, - 'svcnum', 'int', 'NULL', '', + 'routernum', 'serial', '', '', '', '', + 'routername', 'varchar', '', $char_d, '', '', + 'svcnum', 'int', 'NULL', '', '', '', ], 'primary_key' => 'routernum', 'unique' => [], @@ -989,9 +1151,9 @@ sub tables_hashref { 'part_svc_router' => { 'columns' => [ - 'svcrouternum', 'serial', '', '', - 'svcpart', 'int', '', '', - 'routernum', 'int', '', '', + 'svcrouternum', 'serial', '', '', '', '', + 'svcpart', 'int', '', '', '', '', + 'routernum', 'int', '', '', '', '', ], 'primary_key' => 'svcrouternum', 'unique' => [], @@ -1000,10 +1162,10 @@ sub tables_hashref { 'addr_block' => { 'columns' => [ - 'blocknum', 'serial', '', '', - 'routernum', 'int', '', '', - 'ip_gateway', 'varchar', '', 15, - 'ip_netmask', 'int', '', '', + 'blocknum', 'serial', '', '', '', '', + 'routernum', 'int', '', '', '', '', + 'ip_gateway', 'varchar', '', 15, '', '', + 'ip_netmask', 'int', '', '', '', '', ], 'primary_key' => 'blocknum', 'unique' => [ [ 'blocknum', 'routernum' ] ], @@ -1012,11 +1174,18 @@ sub tables_hashref { 'svc_broadband' => { 'columns' => [ - 'svcnum', 'int', '', '', - 'blocknum', 'int', '', '', - 'speed_up', 'int', '', '', - 'speed_down', 'int', '', '', - 'ip_addr', 'varchar', '', 15, + 'svcnum', 'int', '', '', '', '', + 'description', 'varchar', 'NULL', $char_d, '', '', + 'blocknum', 'int', '', '', '', '', + 'speed_up', 'int', '', '', '', '', + 'speed_down', 'int', '', '', '', '', + 'ip_addr', 'varchar', '', 15, '', '', + 'mac_addr', 'varchar', 'NULL', 12, '', '', + 'authkey', 'varchar', 'NULL', 32, '', '', + 'latitude', 'decimal', 'NULL', '', '', '', + 'longitude', 'decimal', 'NULL', '', '', '', + 'altitude', 'decimal', 'NULL', '', '', '', + 'vlan_profile', 'varchar', 'NULL', $char_d, '', '', ], 'primary_key' => 'svcnum', 'unique' => [], @@ -1025,13 +1194,13 @@ sub tables_hashref { 'part_virtual_field' => { 'columns' => [ - 'vfieldpart', 'int', '', '', - 'dbtable', 'varchar', '', 32, - 'name', 'varchar', '', 32, - 'check_block', 'text', 'NULL', '', - 'length', 'int', 'NULL', '', - 'list_source', 'text', 'NULL', '', - 'label', 'varchar', 'NULL', 80, + 'vfieldpart', 'int', '', '', '', '', + 'dbtable', 'varchar', '', 32, '', '', + 'name', 'varchar', '', 32, '', '', + 'check_block', 'text', 'NULL', '', '', '', + 'length', 'int', 'NULL', '', '', '', + 'list_source', 'text', 'NULL', '', '', '', + 'label', 'varchar', 'NULL', 80, '', '', ], 'primary_key' => 'vfieldpart', 'unique' => [], @@ -1040,10 +1209,10 @@ sub tables_hashref { 'virtual_field' => { 'columns' => [ - 'vfieldnum', 'serial', '', '', - 'recnum', 'int', '', '', - 'vfieldpart', 'int', '', '', - 'value', 'varchar', '', 128, + 'vfieldnum', 'serial', '', '', '', '', + 'recnum', 'int', '', '', '', '', + 'vfieldpart', 'int', '', '', '', '', + 'value', 'varchar', '', 128, '', '', ], 'primary_key' => 'vfieldnum', 'unique' => [ [ 'vfieldpart', 'recnum' ] ], @@ -1052,12 +1221,12 @@ sub tables_hashref { 'acct_snarf' => { 'columns' => [ - 'snarfnum', 'int', '', '', - 'svcnum', 'int', '', '', - 'machine', 'varchar', '', 255, - 'protocol', 'varchar', '', $char_d, - 'username', 'varchar', '', $char_d, - '_password', 'varchar', '', $char_d, + 'snarfnum', 'int', '', '', '', '', + 'svcnum', 'int', '', '', '', '', + 'machine', 'varchar', '', 255, '', '', + 'protocol', 'varchar', '', $char_d, '', '', + 'username', 'varchar', '', $char_d, '', '', + '_password', 'varchar', '', $char_d, '', '', ], 'primary_key' => 'snarfnum', 'unique' => [], @@ -1066,9 +1235,9 @@ sub tables_hashref { 'svc_external' => { 'columns' => [ - 'svcnum', 'int', '', '', - 'id', 'int', 'NULL', '', - 'title', 'varchar', 'NULL', $char_d, + 'svcnum', 'int', '', '', '', '', + 'id', 'int', 'NULL', '', '', '', + 'title', 'varchar', 'NULL', $char_d, '', '', ], 'primary_key' => 'svcnum', 'unique' => [], @@ -1077,11 +1246,11 @@ sub tables_hashref { 'cust_pay_refund' => { 'columns' => [ - 'payrefundnum', 'serial', '', '', - 'paynum', 'int', '', '', - 'refundnum', 'int', '', '', - '_date', @date_type, - 'amount', @money_type, + 'payrefundnum', 'serial', '', '', '', '', + 'paynum', 'int', '', '', '', '', + 'refundnum', 'int', '', '', '', '', + '_date', @date_type, '', '', + 'amount', @money_type, '', '', ], 'primary_key' => 'payrefundnum', 'unique' => [], @@ -1090,10 +1259,10 @@ sub tables_hashref { 'part_pkg_option' => { 'columns' => [ - 'optionnum', 'serial', '', '', - 'pkgpart', 'int', '', '', - 'optionname', 'varchar', '', $char_d, - 'optionvalue', 'text', 'NULL', '', + 'optionnum', 'serial', '', '', '', '', + 'pkgpart', 'int', '', '', '', '', + 'optionname', 'varchar', '', $char_d, '', '', + 'optionvalue', 'text', 'NULL', '', '', '', ], 'primary_key' => 'optionnum', 'unique' => [], @@ -1102,8 +1271,8 @@ sub tables_hashref { 'rate' => { 'columns' => [ - 'ratenum', 'serial', '', '', - 'ratename', 'varchar', '', $char_d, + 'ratenum', 'serial', '', '', '', '', + 'ratename', 'varchar', '', $char_d, '', '', ], 'primary_key' => 'ratenum', 'unique' => [], @@ -1112,13 +1281,14 @@ sub tables_hashref { 'rate_detail' => { 'columns' => [ - 'ratedetailnum', 'serial', '', '', - 'ratenum', 'int', '', '', - 'orig_regionnum', 'int', 'NULL', '', - 'dest_regionnum', 'int', '', '', - 'min_included', 'int', '', '', - 'min_charge', @money_type, - 'sec_granularity', 'int', '', '', + 'ratedetailnum', 'serial', '', '', '', '', + 'ratenum', 'int', '', '', '', '', + 'orig_regionnum', 'int', 'NULL', '', '', '', + 'dest_regionnum', 'int', '', '', '', '', + 'min_included', 'int', '', '', '', '', + #'min_charge', @money_type, '', '', + 'min_charge', 'decimal', '', '10,5', '', '', + 'sec_granularity', 'int', '', '', '', '', #time period (link to table of periods)? ], 'primary_key' => 'ratedetailnum', @@ -1128,8 +1298,8 @@ sub tables_hashref { 'rate_region' => { 'columns' => [ - 'regionnum', 'serial', '', '', - 'regionname', 'varchar', '', $char_d, + 'regionnum', 'serial', '', '', '', '', + 'regionname', 'varchar', '', $char_d, '', '', ], 'primary_key' => 'regionnum', 'unique' => [], @@ -1138,11 +1308,11 @@ sub tables_hashref { 'rate_prefix' => { 'columns' => [ - 'prefixnum', 'serial', '', '', - 'regionnum', 'int', '', '',, - 'countrycode', 'varchar', '', 3, - 'npa', 'varchar', 'NULL', 6, - 'nxx', 'varchar', 'NULL', 3, + 'prefixnum', 'serial', '', '', '', '', + 'regionnum', 'int', '', '',, '', '', + 'countrycode', 'varchar', '', 3, '', '', + 'npa', 'varchar', 'NULL', 6, '', '', + 'nxx', 'varchar', 'NULL', 3, '', '', ], 'primary_key' => 'prefixnum', 'unique' => [], @@ -1151,9 +1321,9 @@ sub tables_hashref { 'reg_code' => { 'columns' => [ - 'codenum', 'serial', '', '', - 'code', 'varchar', '', $char_d, - 'agentnum', 'int', '', '', + 'codenum', 'serial', '', '', '', '', + 'code', 'varchar', '', $char_d, '', '', + 'agentnum', 'int', '', '', '', '', ], 'primary_key' => 'codenum', 'unique' => [ [ 'agentnum', 'code' ] ], @@ -1162,9 +1332,9 @@ sub tables_hashref { 'reg_code_pkg' => { 'columns' => [ - 'codepkgnum', 'serial', '', '', - 'codenum', 'int', '', '', - 'pkgpart', 'int', '', '', + 'codepkgnum', 'serial', '', '', '', '', + 'codenum', 'int', '', '', '', '', + 'pkgpart', 'int', '', '', '', '', ], 'primary_key' => 'codepkgnum', 'unique' => [ [ 'codenum', 'pkgpart' ] ], @@ -1173,9 +1343,9 @@ sub tables_hashref { 'clientapi_session' => { 'columns' => [ - 'sessionnum', 'serial', '', '', - 'sessionid', 'varchar', '', $char_d, - 'namespace', 'varchar', '', $char_d, + 'sessionnum', 'serial', '', '', '', '', + 'sessionid', 'varchar', '', $char_d, '', '', + 'namespace', 'varchar', '', $char_d, '', '', ], 'primary_key' => 'sessionnum', 'unique' => [ [ 'sessionid', 'namespace' ] ], @@ -1184,10 +1354,10 @@ sub tables_hashref { 'clientapi_session_field' => { 'columns' => [ - 'fieldnum', 'serial', '', '', - 'sessionnum', 'int', '', '', - 'fieldname', 'varchar', '', $char_d, - 'fieldvalue', 'text', 'NULL', '', + 'fieldnum', 'serial', '', '', '', '', + 'sessionnum', 'int', '', '', '', '', + 'fieldname', 'varchar', '', $char_d, '', '', + 'fieldvalue', 'text', 'NULL', '', '', '', ], 'primary_key' => 'fieldnum', 'unique' => [ [ 'sessionnum', 'fieldname' ] ], @@ -1196,12 +1366,12 @@ sub tables_hashref { 'payment_gateway' => { 'columns' => [ - 'gatewaynum', 'serial', '', '', - 'gateway_module', 'varchar', '', $char_d, - 'gateway_username', 'varchar', 'NULL', $char_d, - 'gateway_password', 'varchar', 'NULL', $char_d, - 'gateway_action', 'varchar', 'NULL', $char_d, - 'disabled', 'char', 'NULL', 1, + 'gatewaynum', 'serial', '', '', '', '', + 'gateway_module', 'varchar', '', $char_d, '', '', + 'gateway_username', 'varchar', 'NULL', $char_d, '', '', + 'gateway_password', 'varchar', 'NULL', $char_d, '', '', + 'gateway_action', 'varchar', 'NULL', $char_d, '', '', + 'disabled', 'char', 'NULL', 1, '', '', ], 'primary_key' => 'gatewaynum', 'unique' => [], @@ -1210,10 +1380,10 @@ sub tables_hashref { 'payment_gateway_option' => { 'columns' => [ - 'optionnum', 'serial', '', '', - 'gatewaynum', 'int', '', '', - 'optionname', 'varchar', '', $char_d, - 'optionvalue', 'text', 'NULL', '', + 'optionnum', 'serial', '', '', '', '', + 'gatewaynum', 'int', '', '', '', '', + 'optionname', 'varchar', '', $char_d, '', '', + 'optionvalue', 'text', 'NULL', '', '', '', ], 'primary_key' => 'optionnum', 'unique' => [], @@ -1222,11 +1392,11 @@ sub tables_hashref { 'agent_payment_gateway' => { 'columns' => [ - 'agentgatewaynum', 'serial', '', '', - 'agentnum', 'int', '', '', - 'gatewaynum', 'int', '', '', - 'cardtype', 'varchar', 'NULL', $char_d, - 'taxclass', 'varchar', 'NULL', $char_d, + 'agentgatewaynum', 'serial', '', '', '', '', + 'agentnum', 'int', '', '', '', '', + 'gatewaynum', 'int', '', '', '', '', + 'cardtype', 'varchar', 'NULL', $char_d, '', '', + 'taxclass', 'varchar', 'NULL', $char_d, '', '', ], 'primary_key' => 'agentgatewaynum', 'unique' => [], @@ -1235,30 +1405,298 @@ sub tables_hashref { 'banned_pay' => { 'columns' => [ - 'bannum', 'serial', '', '', - 'payby', 'char', '', 4, - 'payinfo', 'varchar', '', 128, #say, a 512-big digest _hex encoded - #'paymask', 'varchar', 'NULL', $char_d, - '_date', @date_type, - 'otaker', 'varchar', '', 32, - 'reason', 'varchar', 'NULL', $char_d, + 'bannum', 'serial', '', '', '', '', + 'payby', 'char', '', 4, '', '', + 'payinfo', 'varchar', '', 128, '', '', #say, a 512-big digest _hex encoded + #'paymask', 'varchar', 'NULL', $char_d, '', '' + '_date', @date_type, '', '', + 'otaker', 'varchar', '', 32, '', '', + 'reason', 'varchar', 'NULL', $char_d, '', '', ], 'primary_key' => 'bannum', 'unique' => [ [ 'payby', 'payinfo' ] ], 'index' => [], }, - 'cancel_reason' => { + 'pkg_class' => { + 'columns' => [ + 'classnum', 'serial', '', '', '', '', + 'classname', 'varchar', '', $char_d, '', '', + 'disabled', 'char', 'NULL', 1, '', '', + ], + 'primary_key' => 'classnum', + 'unique' => [], + 'index' => [ ['disabled'] ], + }, + + 'cdr' => { + 'columns' => [ + # qw( name type null length default local ); + + ### + #asterisk fields + ### + + 'acctid', 'bigserial', '', '', '', '', + 'calldate', 'TIMESTAMP with time zone', '', '', \'now()', '', + 'clid', 'varchar', '', $char_d, \"''", '', + 'src', 'varchar', '', $char_d, \"''", '', + 'dst', 'varchar', '', $char_d, \"''", '', + 'dcontext', 'varchar', '', $char_d, \"''", '', + 'channel', 'varchar', '', $char_d, \"''", '', + 'dstchannel', 'varchar', '', $char_d, \"''", '', + 'lastapp', 'varchar', '', $char_d, \"''", '', + 'lastdata', 'varchar', '', $char_d, \"''", '', + + #these don't seem to be logged by most of the SQL cdr_* modules + #except tds under sql-illegal names, so; + # ... don't rely on them for rating? + # and, what they hey, i went ahead and changed the names and data types + # to freeside-style dates... + #'start', 'timestamp', 'NULL', '', '', '', + #'answer', 'timestamp', 'NULL', '', '', '', + #'end', 'timestamp', 'NULL', '', '', '', + 'startdate', @date_type, '', '', + 'answerdate', @date_type, '', '', + 'enddate', @date_type, '', '', + # + + 'duration', 'int', '', '', 0, '', + 'billsec', 'int', '', '', 0, '', + 'disposition', 'varchar', '', 45, \"''", '', + 'amaflags', 'int', '', '', 0, '', + 'accountcode', 'varchar', '', 20, \"''", '', + 'uniqueid', 'varchar', '', 32, \"''", '', + 'userfield', 'varchar', '', 255, \"''", '', + + ### + # fields for unitel/RSLCOM/convergent that don't map well to asterisk + # defaults + ### + + #cdr_type: Usage = 1, S&E = 7, OC&C = 8 + 'cdrtypenum', 'int', 'NULL', '', '', '', + + 'charged_party', 'varchar', 'NULL', $char_d, '', '', + + 'upstream_currency', 'char', 'NULL', 3, '', '', + 'upstream_price', 'decimal', 'NULL', '10,2', '', '', + 'upstream_rateplanid', 'int', 'NULL', '', '', '', #? + + # how it was rated internally... + 'ratedetailnum', 'int', 'NULL', '', '', '', + 'rated_price', 'decimal', 'NULL', '10,2', '', '', + + 'distance', 'decimal', 'NULL', '', '', '', + 'islocal', 'int', 'NULL', '', '', '', # '', '', 0, '' instead? + + #cdr_calltype: the big list in appendix 2 + 'calltypenum', 'int', 'NULL', '', '', '', + + 'description', 'varchar', 'NULL', $char_d, '', '', + 'quantity', 'int', 'NULL', '', '', '', + + #cdr_carrier: Telstra =1, Optus = 2, RSL COM = 3 + 'carrierid', 'int', 'NULL', '', '', '', + + 'upstream_rateid', 'int', 'NULL', '', '', '', + + ### + #and now for our own fields + ### + + # a svcnum... right..? + 'svcnum', 'int', 'NULL', '', '', '', + + #NULL, done (or something) + 'freesidestatus', 'varchar', 'NULL', 32, '', '', + + ], + 'primary_key' => 'acctid', + 'unique' => [], + 'index' => [ [ 'calldate' ], [ 'dst' ], [ 'accountcode' ], [ 'freesidestatus' ] ], + }, + + 'cdr_calltype' => { + 'columns' => [ + 'calltypenum', 'serial', '', '', '', '', + 'calltypename', 'varchar', '', $char_d, '', '', + ], + 'primary_key' => 'calltypenum', + 'unique' => [], + 'index' => [], + }, + + 'cdr_type' => { + 'columns' => [ + 'cdrtypenum' => 'serial', '', '', '', '', + 'cdrtypename' => 'varchar', '', '', '', '', + ], + 'primary_key' => 'cdrtypenum', + 'unique' => [], + 'index' => [], + }, + + 'cdr_carrier' => { + 'columns' => [ + 'carrierid' => 'serial', '', '', '', '', + 'carriername' => 'varchar', '', '', '', '', + ], + 'primary_key' => 'carrierid', + 'unique' => [], + 'index' => [], + }, + + #map upstream rateid to ours... + 'cdr_upstream_rate' => { + 'columns' => [ + 'upstreamratenum', 'serial', '', '', '', '', + 'upstream_rateid', 'varchar', '', $char_d, '', '', + 'ratedetailnum', 'int', 'NULL', '', '', '', + ], + 'primary_key' => 'upstreamratenum', #XXX need a primary key + 'unique' => [ [ 'upstream_rateid' ] ], #unless we add another field, yeah + 'index' => [], + }, + + 'inventory_item' => { + 'columns' => [ + 'itemnum', 'serial', '', '', '', '', + 'classnum', 'int', '', '', '', '', + 'item', 'varchar', '', $char_d, '', '', + 'svcnum', 'int', 'NULL', '', '', '', + ], + 'primary_key' => 'itemnum', + 'unique' => [ [ 'classnum', 'item' ] ], + 'index' => [ [ 'classnum' ], [ 'svcnum' ] ], + }, + + 'inventory_class' => { + 'columns' => [ + 'classnum', 'serial', '', '', '', '', + 'classname', 'varchar', '', $char_d, '', '', + ], + 'primary_key' => 'classnum', + 'unique' => [], + 'index' => [], + }, + + 'access_user' => { + 'columns' => [ + 'usernum', 'serial', '', '', '', '', + 'username', 'varchar', '', $char_d, '', '', + '_password', 'varchar', '', $char_d, '', '', + 'last', 'varchar', '', $char_d, '', '', + 'first', 'varchar', '', $char_d, '', '', + 'disabled', 'char', 'NULL', 1, '', '', + ], + 'primary_key' => 'usernum', + 'unique' => [ [ 'username' ] ], + 'index' => [], + }, + + 'access_user_pref' => { + 'columns' => [ + 'prefnum', 'serial', '', '', '', '', + 'usernum', 'int', '', '', '', '', + 'prefname', 'varchar', '', $char_d, '', '', + 'prefvalue', 'text', 'NULL', '', '', '', + ], + 'primary_key' => 'prefnum', + 'unique' => [], + 'index' => [ [ 'usernum' ] ], + }, + + 'access_group' => { + 'columns' => [ + 'groupnum', 'serial', '', '', '', '', + 'groupname', 'varchar', '', $char_d, '', '', + ], + 'primary_key' => 'groupnum', + 'unique' => [ [ 'groupname' ] ], + 'index' => [], + }, + + 'access_usergroup' => { + 'columns' => [ + 'usergroupnum', 'serial', '', '', '', '', + 'usernum', 'int', '', '', '', '', + 'groupnum', 'int', '', '', '', '', + ], + 'primary_key' => 'usergroupnum', + 'unique' => [ [ 'usernum', 'groupnum' ] ], + 'index' => [ [ 'usernum' ] ], + }, + + 'access_groupagent' => { + 'columns' => [ + 'groupagentnum', 'serial', '', '', '', '', + 'groupnum', 'int', '', '', '', '', + 'agentnum', 'int', '', '', '', '', + ], + 'primary_key' => 'groupagentnum', + 'unique' => [ [ 'groupnum', 'agentnum' ] ], + 'index' => [ [ 'groupnum' ] ], + }, + + 'access_right' => { + 'columns' => [ + 'rightnum', 'serial', '', '', '', '', + 'righttype', 'varchar', '', $char_d, '', '', + 'rightobjnum', 'int', '', '', '', '', + 'rightname', 'varchar', '', '', '', '', + ], + 'primary_key' => 'rightnum', + 'unique' => [ [ 'righttype', 'rightobjnum', 'rightname' ] ], + 'index' => [], + }, + + 'svc_phone' => { 'columns' => [ - 'reasonnum', 'serial', '', '', - 'reason', 'varchar', '', $char_d, - 'disabled', 'char', 'NULL', 1, + 'svcnum', 'int', '', '', '', '', + 'countrycode', 'varchar', '', 3, '', '', + 'phonenum', 'varchar', '', 15, '', '', #12 ? + 'pin', 'varchar', 'NULL', $char_d, '', '', + ], + 'primary_key' => 'svcnum', + 'unique' => [], + 'index' => [ [ 'countrycode', 'phonenum' ] ], + }, + + 'reason_type' => { + 'columns' => [ + 'typenum', 'serial', '', '', '', '', + 'class', 'char', '', 1, '', '', + 'type', 'varchar', '', $char_d, '', '', + ], + 'primary_key' => 'typenum', + 'unique' => [], + 'index' => [], + }, + + 'reason' => { + 'columns' => [ + 'reasonnum', 'serial', '', '', '', '', + 'reason_type', 'int', '', '', '', '', + 'reason', 'varchar', '', $char_d, '', '', + 'disabled', 'char', 'NULL', 1, '', '', ], 'primary_key' => 'reasonnum', 'unique' => [], - 'index' => [ [ 'disabled' ] ], + 'index' => [], }, + # name type nullability length default local + + #'new_table' => { + # 'columns' => [ + # 'num', 'serial', '', '', '', '', + # ], + # 'primary_key' => 'num', + # 'unique' => [], + # 'index' => [], + #}, + }; } diff --git a/FS/FS/Setup.pm b/FS/FS/Setup.pm new file mode 100644 index 000000000..4864cfea8 --- /dev/null +++ b/FS/FS/Setup.pm @@ -0,0 +1,492 @@ +package FS::Setup; + +use strict; +use vars qw( @ISA @EXPORT_OK ); +use Exporter; +#use Tie::DxHash; +use Tie::IxHash; +use FS::UID qw( dbh ); +use FS::Record; + +use FS::svc_domain; +$FS::svc_domain::whois_hack = 1; +$FS::svc_domain::whois_hack = 1; + +@ISA = qw( Exporter ); +@EXPORT_OK = qw( create_initial_data ); + +=head1 NAME + +FS::Setup - Database setup + +=head1 SYNOPSIS + + use FS::Setup; + +=head1 DESCRIPTION + +Currently this module simply provides a place to store common subroutines for +database setup. + +=head1 SUBROUTINES + +=over 4 + +=item + +=cut + +sub create_initial_data { + my %opt = @_; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + $FS::UID::AutoCommit = 0; + + populate_locales(); + + #initial_data data + populate_initial_data(%opt); + + populate_access(); + + populate_msgcat(); + + if ( $oldAutoCommit ) { + dbh->commit or die dbh->errstr; + } + +} + +sub populate_locales { + + use Locale::Country; + use FS::cust_main_county; + + #cust_main_county + foreach my $country ( sort map uc($_), all_country_codes ) { + _add_country($country); + } + +} + +sub populate_addl_locales { + + my %addl = ( + 'US' => { + 'FM' => 'Federated States of Micronesia', + 'MH' => 'Marshall Islands', + 'PW' => 'Palau', + 'AA' => "Armed Forces Americas (except Canada)", + 'AE' => "Armed Forces Europe / Canada / Middle East / Africa", + 'AP' => "Armed Forces Pacific", + }, + ); + + foreach my $country ( keys %addl ) { + foreach my $state ( keys %{ $addl{$country} } ) { + # $longname = $addl{$country}{$state}; + _add_locale( 'country'=>$country, 'state'=>$state); + } + } + +} + +sub _add_country { + + use Locale::SubCountry; + + my( $country ) = shift; + + my $subcountry = eval { new Locale::SubCountry($country) }; + my @states = $subcountry ? $subcountry->all_codes : undef; + + if ( !scalar(@states) || ( scalar(@states)==1 && !defined($states[0]) ) ) { + + _add_locale( 'country'=>$country ); + + } else { + + if ( $states[0] =~ /^(\d+|\w)$/ ) { + @states = map $subcountry->full_name($_), @states + } + + foreach my $state ( @states ) { + _add_locale( 'country'=>$country, 'state'=>$state); + } + + } + +} + +sub _add_locale { + my $cust_main_county = new FS::cust_main_county( { 'tax'=>0, @_ }); + my $error = $cust_main_county->insert; + die $error if $error; +} + +sub populate_initial_data { + my %opt = @_; + + my $data = initial_data(%opt); + + foreach my $table ( keys %$data ) { + + my $class = "FS::$table"; + eval "use $class;"; + die $@ if $@; + + my @records = @{ $data->{$table} }; + + foreach my $record ( @records ) { + my $args = delete($record->{'_insert_args'}) || []; + my $object = $class->new( $record ); + my $error = $object->insert( @$args ); + die "error inserting record into $table: $error\n" + if $error; + } + + } + +} + +sub initial_data { + my %opt = @_; + + #tie my %hash, 'Tie::DxHash', + tie my %hash, 'Tie::IxHash', + + #superuser group + 'access_group' => [ + { 'groupname' => 'Superuser' }, + ], + + #billing events + 'part_bill_event' => [ + { 'payby' => 'CARD', + 'event' => 'Batch card', + 'seconds' => 0, + 'eventcode' => '$cust_bill->batch_card(%options);', + 'weight' => 40, + 'plan' => 'batch-card', + }, + { 'payby' => 'BILL', + 'event' => 'Send invoice', + 'seconds' => 0, + 'eventcode' => '$cust_bill->send();', + 'weight' => 50, + 'plan' => 'send', + }, + { 'payby' => 'DCRD', + 'event' => 'Send invoice', + 'seconds' => 0, + 'eventcode' => '$cust_bill->send();', + 'weight' => 50, + 'plan' => 'send', + }, + { 'payby' => 'DCHK', + 'event' => 'Send invoice', + 'seconds' => 0, + 'eventcode' => '$cust_bill->send();', + 'weight' => 50, + 'plan' => 'send', + }, + { 'payby' => 'DCLN', + 'event' => 'Suspend', + 'seconds' => 0, + 'eventcode' => '$cust_bill->suspend();', + 'weight' => 40, + 'plan' => 'suspend', + }, + #{ 'payby' => 'DCLN', + # 'event' => 'Retriable', + # 'seconds' => 0, + # 'eventcode' => '$cust_bill_event->retriable();', + # 'weight' => 60, + # 'plan' => 'retriable', + #}, + ], + + #you must create a service definition. An example of a service definition + #would be a dial-up account or a domain. First, it is necessary to create a + #domain definition. Click on View/Edit service definitions and Add a new + #service definition with Table svc_domain (and no modifiers). + 'part_svc' => [ + { 'svc' => 'Domain', + 'svcdb' => 'svc_domain', + } + ], + + #Now that you have created your first service, you must create a package + #including this service which you can sell to customers. Zero, one, or many + #services are bundled into a package. Click on View/Edit package + #definitions and Add a new package definition which includes quantity 1 of + #the svc_domain service you created above. + 'part_pkg' => [ + { 'pkg' => 'System Domain', + 'comment' => '(NOT FOR CUSTOMERS)', + 'freq' => '0', + 'plan' => 'flat', + '_insert_args' => [ + 'pkg_svc' => { 1 => 1 }, # XXX + 'primary_svc' => 1, #XXX + 'options' => { + 'setup_fee' => '0', + 'recur_fee' => '0', + }, + ], + }, + ], + + #After you create your first package, then you must define who is able to + #sell that package by creating an agent type. An example of an agent type + #would be an internal sales representitive which sells regular and + #promotional packages, as opposed to an external sales representitive + #which would only sell regular packages of services. Click on View/Edit + #agent types and Add a new agent type. + 'agent_type' => [ + { 'atype' => 'internal' }, + ], + + #Allow this agent type to sell the package you created above. + 'type_pkgs' => [ + { 'typenum' => 1, #XXX + 'pkgpart' => 1, #XXX + }, + ], + + #After creating a new agent type, you must create an agent. Click on + #View/Edit agents and Add a new agent. + 'agent' => [ + { 'agent' => 'Internal', + 'typenum' => 1, # XXX + }, + ], + + #Set up at least one Advertising source. Advertising sources will help you + #keep track of how effective your advertising is, tracking where customers + #heard of your service offerings. You must create at least one advertising + #source. If you do not wish to use the referral functionality, simply + #create a single advertising source only. Click on View/Edit advertising + #sources and Add a new advertising source. + 'part_referral' => [ + { 'referral' => 'Internal', }, + ], + + #Click on New Customer and create a new customer for your system accounts + #with billing type Complimentary. Leave the First package dropdown set to + #(none). + 'cust_main' => [ + { 'agentnum' => 1, #XXX + 'refnum' => 1, #XXX + 'first' => 'System', + 'last' => 'Accounts', + 'address1' => '1234 System Lane', + 'city' => 'Systemtown', + 'state' => 'CA', + 'zip' => '54321', + 'country' => 'US', + 'payby' => 'COMP', + 'payinfo' => 'system', #or something + 'paydate' => '1/2037', + }, + ], + + #From the Customer View screen of the newly created customer, order the + #package you defined above. + 'cust_pkg' => [ + { 'custnum' => 1, #XXX + 'pkgpart' => 1, #XXX + }, + ], + + #From the Package View screen of the newly created package, choose + #(Provision) to add the customer's service for this new package. + #Add your own domain. + 'svc_domain' => [ + { 'domain' => $opt{'domain'}, + 'pkgnum' => 1, #XXX + 'svcpart' => 1, #XXX + 'action' => 'N', #pseudo-field + }, + ], + + #Go back to View/Edit service definitions on the main menu, and Add a new + #service definition with Table svc_acct. Select your domain in the domsvc + #Modifier. Set Fixed to define a service locked-in to this domain, or + #Default to define a service which may select from among this domain and + #the customer's domains. + + #not yet.... + + #) + ; + + \%hash; + +} + +sub populate_access { + + use FS::AccessRight; + use FS::access_right; + + foreach my $rightname ( FS::AccessRight->rights ) { + my $access_right = new FS::access_right { + 'righttype' => 'FS::access_group', + 'rightobjnum' => 1, #$supergroup->groupnum, + 'rightname' => $rightname, + }; + my $ar_error = $access_right->insert; + die $ar_error if $ar_error; + } + + #foreach my $agent ( qsearch('agent', {} ) ) { + my $access_groupagent = new FS::access_groupagent { + 'groupnum' => 1, #$supergroup->groupnum, + 'agentnum' => 1, #$agent->agentnum, + }; + my $aga_error = $access_groupagent->insert; + die $aga_error if $aga_error; + #} + +} + +sub populate_msgcat { + + use FS::Record qw(qsearch); + use FS::msgcat; + + foreach my $del_msgcat ( qsearch('msgcat', {}) ) { + my $error = $del_msgcat->delete; + die $error if $error; + } + + my %messages = msgcat_messages(); + + foreach my $msgcode ( keys %messages ) { + foreach my $locale ( keys %{$messages{$msgcode}} ) { + my $msgcat = new FS::msgcat( { + 'msgcode' => $msgcode, + 'locale' => $locale, + 'msg' => $messages{$msgcode}{$locale}, + }); + my $error = $msgcat->insert; + die $error if $error; + } + } + +} + +sub msgcat_messages { + + # 'msgcode' => { + # 'en_US' => 'Message', + # }, + + ( + + 'passwords_dont_match' => { + 'en_US' => "Passwords don't match", + }, + + 'invalid_card' => { + 'en_US' => 'Invalid credit card number', + }, + + 'unknown_card_type' => { + 'en_US' => 'Unknown card type', + }, + + 'not_a' => { + 'en_US' => 'Not a ', + }, + + 'empty_password' => { + 'en_US' => 'Empty password', + }, + + 'no_access_number_selected' => { + 'en_US' => 'No access number selected', + }, + + 'illegal_text' => { + 'en_US' => 'Illegal (text)', + #'en_US' => 'Only letters, numbers, spaces, and the following punctuation symbols are permitted: ! @ # $ % & ( ) - + ; : \' " , . ? / in field', + }, + + 'illegal_or_empty_text' => { + 'en_US' => 'Illegal or empty (text)', + #'en_US' => 'Only letters, numbers, spaces, and the following punctuation symbols are permitted: ! @ # $ % & ( ) - + ; : \' " , . ? / in required field', + }, + + 'illegal_username' => { + 'en_US' => 'Illegal username', + }, + + 'illegal_password' => { + 'en_US' => 'Illegal password (', + }, + + 'illegal_password_characters' => { + 'en_US' => ' characters)', + }, + + 'username_in_use' => { + 'en_US' => 'Username in use', + }, + + 'illegal_email_invoice_address' => { + 'en_US' => 'Illegal email invoice address', + }, + + 'illegal_name' => { + 'en_US' => 'Illegal (name)', + #'en_US' => 'Only letters, numbers, spaces and the following punctuation symbols are permitted: , . - \' in field', + }, + + 'illegal_phone' => { + 'en_US' => 'Illegal (phone)', + #'en_US' => '', + }, + + 'illegal_zip' => { + 'en_US' => 'Illegal (zip)', + #'en_US' => '', + }, + + 'expired_card' => { + 'en_US' => 'Expired card', + }, + + 'daytime' => { + 'en_US' => 'Day Phone', + }, + + 'night' => { + 'en_US' => 'Night Phone', + }, + + 'svc_external-id' => { + 'en_US' => 'External ID', + }, + + 'svc_external-title' => { + 'en_US' => 'Title', + }, + + ); +} + +=back + +=head1 BUGS + +Sure. + +=head1 SEE ALSO + +=cut + +1; + diff --git a/FS/FS/TicketSystem/RT_External.pm b/FS/FS/TicketSystem/RT_External.pm index d951cc0e7..3a0d6f0a5 100644 --- a/FS/FS/TicketSystem/RT_External.pm +++ b/FS/FS/TicketSystem/RT_External.pm @@ -10,7 +10,7 @@ use FS::Record qw(qsearchs); use FS::cust_main; FS::UID->install_callback( sub { - my $conf = new FS::Conf; + $conf = new FS::Conf; $default_queueid = $conf->config('ticket_system-default_queueid'); $priority_field = $conf->config('ticket_system-custom_priority_field'); @@ -55,9 +55,11 @@ sub customer_tickets { $limit ||= 0; my( $from_sql, @param) = $self->_from_customer( $custnum, $priority ); - my $sql = "SELECT tickets.*, queues.name". - ( length($priority) ? ", objectcustomfieldvalues.content" : '' ). - " $from_sql ORDER BY priority DESC LIMIT $limit"; + my $sql="SELECT tickets.*, queues.name, ". + "position(tickets.status in 'newopenstalledresolvedrejecteddeleted')". + " AS svalue " . + ( length($priority) ? ", objectcustomfieldvalues.content" : '' ). + " $from_sql ORDER BY svalue, priority DESC, id DESC LIMIT $limit"; my $sth = $dbh->prepare($sql) or die $dbh->errstr. "preparing $sql"; $sth->execute(@param) or die $sth->errstr. "executing $sql"; @@ -109,6 +111,7 @@ sub _from_customer { ON ( tickets.id = ObjectCustomFieldValues.ObjectId )"; $where = " AND content = ? + AND ObjectCustomFieldValues.disabled != 1 AND ObjectType = 'RT::Ticket' AND $customfield_sql"; @@ -130,7 +133,7 @@ sub _from_customer { JOIN queues ON ( tickets.queue = queues.id ) JOIN links ON ( tickets.id = links.localbase ) $join - WHERE ( status = 'new' OR status = 'open' OR status = 'stalled' ) + WHERE ( ". join(' OR ', map "status = '$_'", $self->statuses ). " ) AND target = 'freeside://freeside/cust_main/$custnum' $where "; @@ -139,31 +142,44 @@ sub _from_customer { } +sub statuses { + #my $self = shift; + my @statuses = grep { ! /^\s*$/ } $conf->config('cust_main-ticket_statuses'); + @statuses = (qw( new open stalled )) unless scalar(@statuses); + @statuses; +} + sub href_customer_tickets { my( $self, $custnum, $priority ) = @_; - my $href = $self->baseurl; + #my $href = $self->baseurl; - #i snarfed this from an RT bookmarked search, it could be unescaped in the - #source for readability and run through uri_escape - $href .= - 'Search/Results.html?Order=ASC&Query=%20MemberOf%20%3D%20%27freeside%3A%2F%2Ffreeside%2Fcust_main%2F'. - $custnum. - '%27%20%20AND%20%28%20Status%20%3D%20%27open%27%20%20OR%20Status%20%3D%20%27new%27%20%20OR%20Status%20%3D%20%27stalled%27%20%29%20' + #i snarfed this from an RT bookmarked search, then unescaped (some of) it with + #perl -npe 's/%([0-9A-F]{2})/pack('C', hex($1))/eg;' + + my $href .= + "Search/Results.html?Order=ASC&". + "Query= MemberOf = 'freeside://freeside/cust_main/$custnum' ". + #" AND ( Status = 'open' OR Status = 'new' OR Status = 'stalled' )" + " AND ( ". join(' OR ', map "Status = '$_'", $self->statuses ). " ) " ; if ( defined($priority) && $field && $priority_field_queue ) { - $href .= 'AND%20Queue%20%3D%20%27'. $priority_field_queue. '%27%20'; + $href .= " AND Queue = '$priority_field_queue' "; } if ( defined($priority) && $field ) { - $href .= '%20AND%20%27CF.'. $field. '%27%20'; + $href .= " AND 'CF.$field' "; if ( $priority ) { - $href .= '%3D%20%27'. $priority. '%27%20'; + $href .= "= '$priority' "; } else { - $href .= 'IS%20%27NULL%27%20'; + $href .= "IS 'NULL' "; #this is "RTQL", not SQL } } + #$href = + uri_escape($href); + #eventually should unescape all of it... + $href .= '&Rows=100'. '&OrderBy=id&Page=1'. '&Format=%27%20%20%20%3Cb%3E%3Ca%20href%3D%22'. @@ -184,7 +200,10 @@ sub href_customer_tickets { $href .= '%20%0A%27%3Csmall%3E__ToldRelative__%3C%2Fsmall%3E%27%2C%20%0A%27%3Csmall%3E__LastUpdatedRelative__%3C%2Fsmall%3E%27%2C%20%0A%27%3Csmall%3E__TimeLeft__%3C%2Fsmall%3E%27'; - $href; + #$href = + #uri_escape($href); + + $self->baseurl. $href; } diff --git a/FS/FS/UI/Web.pm b/FS/FS/UI/Web.pm index 49e3fbf7e..9ddcf142d 100644 --- a/FS/FS/UI/Web.pm +++ b/FS/FS/UI/Web.pm @@ -1,6 +1,7 @@ package FS::UI::Web; -use vars qw($DEBUG); +use strict; +use vars qw($DEBUG $me); use FS::Conf; use FS::Record qw(dbdef); @@ -8,21 +9,29 @@ use FS::Record qw(dbdef); #use FS::UI #@ISA = qw( FS::UI ); +$DEBUG = 0; +$me = '[FS::UID::Web]'; + +### +# date parsing +### + use Date::Parse; sub parse_beginning_ending { - my($cgi) = @_; + my($cgi, $prefix) = @_; + $prefix .= '_' if $prefix; my $beginning = 0; - if ( $cgi->param('begin') =~ /^(\d+)$/ ) { + if ( $cgi->param($prefix.'begin') =~ /^(\d+)$/ ) { $beginning = $1; - } elsif ( $cgi->param('beginning') =~ /^([ 0-9\-\/]{1,64})$/ ) { + } elsif ( $cgi->param($prefix.'beginning') =~ /^([ 0-9\-\/]{1,64})$/ ) { $beginning = str2time($1) || 0; } my $ending = 4294967295; #2^32-1 - if ( $cgi->param('end') =~ /^(\d+)$/ ) { + if ( $cgi->param($prefix.'end') =~ /^(\d+)$/ ) { $ending = $1 - 1; - } elsif ( $cgi->param('ending') =~ /^([ 0-9\-\/]{1,64})$/ ) { + } elsif ( $cgi->param($prefix.'ending') =~ /^([ 0-9\-\/]{1,64})$/ ) { #probably need an option to turn off the + 86399 $ending = str2time($1) + 86399; } @@ -30,84 +39,295 @@ sub parse_beginning_ending { ( $beginning, $ending ); } -### -# cust_main report methods -### +=item svc_url + +Returns a service URL, first checking to see if there is a service-specific +page to link to, otherwise to a generic service handling page. Options are +passed as a list of name-value pairs, and include: + +=over 4 + +=item * m - Mason request object ($m) + +=item * action - The action for which to construct "edit", "view", or "search" + +=item ** part_svc - Service definition (see L<FS::part_svc>) + +=item ** svcdb - Service table + +=item *** query - Query string + +=item *** svc - FS::cust_svc or FS::svc_* object -=item cust_header +=item ahref - Optional flag, if set true returns <A HREF="$url"> instead of just the URL. -Returns an array of customer information headers according to the -B<cust-fields> configuration setting. +=back + +* Required fields + +** part_svc OR svcdb is required + +*** query OR svc is required =cut -use vars qw( @cust_fields ); + # ## + # #required + # ## + # 'm' => $m, #mason request object + # 'action' => 'edit', #or 'view' + # + # 'part_svc' => $part_svc, #usual + # #OR + # 'svcdb' => 'svc_table', + # + # 'query' => #optional query string + # # (pass a blank string if you want a "raw" URL to add your + # # own svcnum to) + # #OR + # 'svc' => $svc_x, #or $cust_svc, it just needs a svcnum + # + # ## + # #optional + # ## + # 'ahref' => 1, # if set true, returns <A HREF="$url"> + +use FS::CGI qw(rooturl); +sub svc_url { + my %opt = @_; + + #? return '' unless ref($opt{part_svc}); + + my $svcdb = $opt{svcdb} || $opt{part_svc}->svcdb; + my $query = exists($opt{query}) ? $opt{query} : $opt{svc}->svcnum; + my $url; + warn "$me [svc_url] checking for /$opt{action}/$svcdb.cgi component" + if $DEBUG; + if ( $opt{m}->interp->comp_exists("/$opt{action}/$svcdb.cgi") ) { + $url = "$svcdb.cgi?"; + } else { -sub cust_sql_fields { - my @fields = qw( last first company ); - push @fields, map "ship_$_", @fields - if dbdef->table('cust_main')->column('ship_last'); - map "cust_main.$_", @fields; + my $generic = $opt{action} eq 'search' ? 'cust_svc' : 'svc_Common'; + + $url = "$generic.html?svcdb=$svcdb;"; + $url .= 'svcnum=' if $query =~ /^\d+(;|$)/ or $query eq ''; + } + + my $return = rooturl(). "$opt{action}/$url$query"; + + $return = qq!<A HREF="$return">! if $opt{ahref}; + + $return; +} + +sub svc_link { + my($m, $part_svc, $cust_svc) = @_ or return ''; + svc_X_link( $part_svc->svc, @_ ); } +sub svc_label_link { + my($m, $part_svc, $cust_svc) = @_ or return ''; + svc_X_link( ($cust_svc->label)[1], @_ ); +} + +sub svc_X_link { + my ($x, $m, $part_svc, $cust_svc) = @_ or return ''; + my $ahref = svc_url( + 'ahref' => 1, + 'm' => $m, + 'action' => 'view', + 'part_svc' => $part_svc, + 'svc' => $cust_svc, + ); + + "$ahref$x</A>"; +} + +sub parse_lt_gt { + my($cgi, $field) = @_; + + my @search = (); + + my %op = ( + 'lt' => '<', + 'gt' => '>', + ); + + foreach my $op (keys %op) { + + warn "checking for ${field}_$op field\n" + if $DEBUG; + + if ( $cgi->param($field."_$op") =~ /^\s*\$?\s*([\d\,\s]+(\.\d\d)?)\s*$/ ) { + + my $num = $1; + $num =~ s/[\,\s]+//g; + my $search = "$field $op{$op} $num"; + push @search, $search; + + warn "found ${field}_$op field; adding search element $search\n" + if $DEBUG; + } + + } + + @search; + +} + +sub bytecount_unexact { + my $bc = shift; + return("$bc bytes") + if ($bc < 1000); + return(sprintf("%.2f Kbytes", $bc/1000)) + if ($bc < 1000000); + return(sprintf("%.2f Mbytes", $bc/1000000)) + if ($bc < 1000000000); + return(sprintf("%.2f Gbytes", $bc/1000000000)); +} + +### +# cust_main report subroutines +### + + +=item cust_header [ CUST_FIELDS_VALUE ] + +Returns an array of customer information headers according to the supplied +customer fields value, or if no value is supplied, the B<cust-fields> +configuration value. + +=cut + +use vars qw( @cust_fields @cust_colors @cust_styles @cust_aligns ); + sub cust_header { - warn "FS::svc_Common::cust_header called" + warn "FS::UI:Web::cust_header called" if $DEBUG; - my $conf = new FS::Conf; - my %header2method = ( - 'Customer' => 'name', - 'Cust#' => 'custnum', - 'Name' => 'contact', - 'Company' => 'company', - '(bill) Customer' => 'name', - '(service) Customer' => 'ship_name', - '(bill) Name' => 'contact', - '(service) Name' => 'ship_contact', - '(bill) Company' => 'company', - '(service) Company' => 'ship_company', + 'Customer' => 'name', + 'Cust. Status' => 'ucfirst_cust_status', + 'Cust#' => 'custnum', + 'Name' => 'contact', + 'Company' => 'company', + '(bill) Customer' => 'name', + '(service) Customer' => 'ship_name', + '(bill) Name' => 'contact', + '(service) Name' => 'ship_contact', + '(bill) Company' => 'company', + '(service) Company' => 'ship_company', + 'Address 1' => 'address1', + 'Address 2' => 'address2', + 'City' => 'city', + 'State' => 'state', + 'Zip' => 'zip', + 'Country' => 'country_full', + 'Day phone' => 'daytime', # XXX should use msgcat, but how? + 'Night phone' => 'night', # XXX should use msgcat, but how? + 'Invoicing email(s)' => 'invoicing_list_emailonly_scalar', + ); + + my %header2colormethod = ( + 'Cust. Status' => 'cust_statuscolor', + ); + my %header2style = ( + 'Cust. Status' => 'b', + ); + my %header2align = ( + 'Cust. Status' => 'c', ); + my $cust_fields; my @cust_header; - if ( $conf->exists('cust-fields') - && $conf->config('cust-fields') =~ /^([\w \|\#\(\)]+):/ - ) - { - warn " found cust-fields configuration value" - if $DEBUG; + if ( @_ && $_[0] ) { - my $cust_fields = $1; - @cust_header = split(/ \| /, $cust_fields); - @cust_fields = map { $header2method{$_} } @cust_header; - } else { - warn " no cust-fields configuration value found; using default 'Customer'" + warn " using supplied cust-fields override". + " (ignoring cust-fields config file)" if $DEBUG; - @cust_header = ( 'Customer' ); - @cust_fields = ( 'name' ); + $cust_fields = shift; + + } else { + + my $conf = new FS::Conf; + if ( $conf->exists('cust-fields') + && $conf->config('cust-fields') =~ /^([\w\. \|\#\(\)]+):?/ + ) + { + warn " found cust-fields configuration value" + if $DEBUG; + $cust_fields = $1; + } else { + warn " no cust-fields configuration value found; using default 'Cust. Status | Customer'" + if $DEBUG; + $cust_fields = 'Cust. Status | Customer'; + } + } + @cust_header = split(/ \| /, $cust_fields); + @cust_fields = map { $header2method{$_} } @cust_header; + @cust_colors = map { exists $header2colormethod{$_} + ? $header2colormethod{$_} + : '' + } + @cust_header; + @cust_styles = map { exists $header2style{$_} ? $header2style{$_} : '' } + @cust_header; + @cust_aligns = map { exists $header2align{$_} ? $header2align{$_} : 'l' } + @cust_header; + #my $svc_x = shift; @cust_header; } -=item cust_fields +=item cust_sql_fields [ CUST_FIELDS_VALUE ] + +Returns a list of fields for the SELECT portion of an SQL query. + +As with L<the cust_header subroutine|/cust_header>, the fields returned are +defined by the supplied customer fields setting, or if no customer fields +setting is supplied, the <B>cust-fields</B> configuration value. + +=cut + +sub cust_sql_fields { + + my @fields = qw( last first company ); + push @fields, map "ship_$_", @fields; + push @fields, 'country'; + + cust_header(@_); + #inefficientish, but tiny lists and only run once per page + push @fields, + grep { my $field = $_; grep { $_ eq $field } @cust_fields } + qw( address1 address2 city state zip daytime night ); + + map "cust_main.$_", @fields; +} + +=item cust_fields OBJECT [ CUST_FIELDS_VALUE ] -Given a svc_ object that contains fields from cust_main (say, from a +Given an object that contains fields from cust_main (say, from a JOINed search. See httemplate/search/svc_* for examples), returns an array -of customer information according to the <B>cust-fields</B> configuration -setting, or "(unlinked)" if this service is not linked to a customer. +of customer information, or "(unlinked)" if this service is not linked to a +customer. + +As with L<the cust_header subroutine|/cust_header>, the fields returned are +defined by the supplied customer fields setting, or if no customer fields +setting is supplied, the <B>cust-fields</B> configuration value. =cut sub cust_fields { my $svc_x = shift; - warn "FS::svc_Common::cust_fields called for $svc_x ". + warn "FS::UI::Web::cust_fields called for $svc_x ". "(cust_fields: @cust_fields)" if $DEBUG > 1; - cust_header() unless @cust_fields; + #cust_header(@_) unless @cust_fields; #now need to cache to keep cust_fields + # #override incase we were passed as a sub my $seen_unlinked = 0; map { @@ -123,6 +343,67 @@ sub cust_fields { } @cust_fields; } +=item cust_colors + +Returns an array of subroutine references (or empty strings) for returning +customer information colors. + +As with L<the cust_header subroutine|/cust_header>, the fields returned are +defined by the supplied customer fields setting, or if no customer fields +setting is supplied, the <B>cust-fields</B> configuration value. + +=cut + +sub cust_colors { + map { + my $method = $_; + if ( $method ) { + sub { shift->$method(@_) }; + } else { + ''; + } + } @cust_colors; +} + +=item cust_styles + +Returns an array of customer information styles. + +As with L<the cust_header subroutine|/cust_header>, the fields returned are +defined by the supplied customer fields setting, or if no customer fields +setting is supplied, the <B>cust-fields</B> configuration value. + +=cut + +sub cust_styles { + map { + if ( $_ ) { + $_; + } else { + ''; + } + } @cust_styles; +} + +=item cust_aligns + +Returns an array or scalar (depending on context) of customer information +alignments. + +As with L<the cust_header subroutine|/cust_header>, the fields returned are +defined by the supplied customer fields setting, or if no customer fields +setting is supplied, the <B>cust-fields</B> configuration value. + +=cut + +sub cust_aligns { + if ( wantarray ) { + @cust_aligns; + } else { + join('', @cust_aligns); + } +} + ### # begin JSRPC code... ### @@ -131,6 +412,7 @@ package FS::UI::Web::JSRPC; use strict; use vars qw($DEBUG); +use Carp; use Storable qw(nfreeze); use MIME::Base64; use JSON; @@ -150,7 +432,7 @@ sub new { bless $self, $class; - die "CGI object required as second argument" unless $self->{'cgi'}; + croak "CGI object required as second argument" unless $self->{'cgi'}; return $self; } @@ -183,6 +465,10 @@ sub process { $self->job_status(@args); + } else { + + die "unknown sub $sub"; + } } @@ -227,11 +513,19 @@ sub start_job { my $error = $job->insert( '_JOB', encode_base64(nfreeze(\%param)) ); if ( $error ) { + + warn "job not inserted: $error\n" + if $DEBUG; + $error; #this doesn't seem to be handled well, # will trigger "illegal jobnum" below? # (should never be an error inserting the job, though, only thing # would be Pg f%*kage) } else { + + warn "job inserted successfully with jobnum ". $job->jobnum. "\n" + if $DEBUG; + $job->jobnum; } @@ -252,7 +546,7 @@ sub job_status { my @return; if ( $job && $job->status ne 'failed' ) { @return = ( 'progress', $job->statustext ); - } elsif ( !$job ) { #handle job gone case : job sucessful + } elsif ( !$job ) { #handle job gone case : job successful # so close popup, redirect parent window... @return = ( 'complete' ); } else { diff --git a/FS/FS/UID.pm b/FS/FS/UID.pm index c0c9f7af4..8dd928ec7 100644 --- a/FS/FS/UID.pm +++ b/FS/FS/UID.pm @@ -10,9 +10,10 @@ use subs qw( getsecrets cgisetotaker ); use Exporter; -use Carp qw(carp croak cluck); +use Carp qw(carp croak cluck confess); use DBI; use FS::Conf; +use FS::CurrentUser; @ISA = qw(Exporter); @EXPORT_OK = qw(checkeuid checkruid cgisuidsetup adminsuidsetup forksuidsetup @@ -20,7 +21,7 @@ use FS::Conf; $freeside_uid = scalar(getpwnam('freeside')); -$conf_dir = "/usr/local/etc/freeside/"; +$conf_dir = "%%%FREESIDE_CONF%%%/"; $AutoCommit = 1; #ours, not DBI @@ -71,10 +72,16 @@ sub adminsuidsetup { sub forksuidsetup { $user = shift; - croak "fatal: adminsuidsetup called without arguements" unless $user; + my $olduser = $user; - $user =~ /^([\w\-\.]+)$/ or croak "fatal: illegal user $user"; - $user = $1; + if ( $FS::CurrentUser::upgrade_hack ) { + $user = 'fs_bootstrap'; + } else { + 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'; @@ -85,7 +92,17 @@ sub forksuidsetup { croak "Not running uid freeside!" unless checkeuid(); - $dbh = &myconnect; + if ( $FS::CurrentUser::upgrade_hack && $olduser ) { + $dbh = &myconnect($olduser); + } else { + $dbh = &myconnect(); + } + + use FS::Schema qw(reload_dbdef); + reload_dbdef("$conf_dir/dbdef.$datasrc") + unless $FS::Schema::setup_hack; + + FS::CurrentUser->load_user($user); foreach ( keys %callback ) { &{$callback{$_}}; @@ -98,7 +115,11 @@ sub forksuidsetup { } sub myconnect { - DBI->connect( getsecrets, {'AutoCommit' => 0, 'ChopBlanks' => 1, } ) + DBI->connect( getsecrets(@_), { 'AutoCommit' => 0, + 'ChopBlanks' => 1, + 'ShowErrorStatement' => 1, + } + ) or die "DBI->connect error: $DBI::errstr\n"; } @@ -254,15 +275,22 @@ the `/usr/local/etc/freeside/mapsecrets' file. 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; + + if ( $conf->exists('mapsecrets') ) { + die "No user!" unless $user; + my($line) = grep /^\s*($user|\*)\s/, $conf->config('mapsecrets'); + confess "User $user not found in mapsecrets!" unless $line; + $line =~ /^\s*($user|\*)\s+(.*)$/; + $secrets = $2; + die "Illegal mapsecrets line for user?!" unless $secrets; + } else { + # no mapsecrets file at all, so do the default thing + $secrets = 'secrets'; + } + ($datasrc, $db_user, $db_pass) = $conf->config($secrets) - or die "Can't get secrets: $!"; + or die "Can't get secrets: $secrets: $!\n"; $FS::Conf::default_dir = $conf_dir. "/conf.$datasrc"; undef $driver_name; ($datasrc, $db_user, $db_pass); diff --git a/FS/FS/access_group.pm b/FS/FS/access_group.pm new file mode 100644 index 000000000..25190406f --- /dev/null +++ b/FS/FS/access_group.pm @@ -0,0 +1,162 @@ +package FS::access_group; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); +use FS::m2name_Common; +use FS::access_groupagent; +use FS::access_right; + +@ISA = qw(FS::m2m_Common FS::m2name_Common FS::Record); + +=head1 NAME + +FS::access_group - Object methods for access_group records + +=head1 SYNOPSIS + + use FS::access_group; + + $record = new FS::access_group \%hash; + $record = new FS::access_group { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::access_group object represents an access group. FS::access_group inherits from +FS::Record. The following fields are currently supported: + +=over 4 + +=item groupnum - primary key + +=item groupname - Access group name + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new access group. To add the access group 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 { 'access_group'; } + +=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 access group. 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('groupnum') + || $self->ut_text('groupname') + ; + return $error if $error; + + $self->SUPER::check; +} + +=item access_groupagent + +Returns all associated FS::access_groupagent records. + +=cut + +sub access_groupagent { + my $self = shift; + qsearch('access_groupagent', { 'groupnum' => $self->groupnum } ); +} + +=item access_rights + +Returns all associated FS::access_right records. + +=cut + +sub access_rights { + my $self = shift; + qsearch('access_right', { 'righttype' => 'FS::access_group', + 'rightobjnum' => $self->groupnum + } + ); +} + +=item access_right RIGHTNAME + +Returns the specified FS::access_right record. Can be used as a boolean, to +test if this group has the given RIGHTNAME. + +=cut + +sub access_right { + my( $self, $name ) = shift; + qsearchs('access_right', { 'righttype' => 'FS::access_group', + 'rightobjnum' => $self->groupnum, + 'rightname' => $name, + } + ); +} + +=back + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/access_groupagent.pm b/FS/FS/access_groupagent.pm new file mode 100644 index 000000000..3de8feeed --- /dev/null +++ b/FS/FS/access_groupagent.pm @@ -0,0 +1,134 @@ +package FS::access_groupagent; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); +use FS::agent; + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::access_groupagent - Object methods for access_groupagent records + +=head1 SYNOPSIS + + use FS::access_groupagent; + + $record = new FS::access_groupagent \%hash; + $record = new FS::access_groupagent { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::access_groupagent object represents an group reseller virtualization. FS::access_groupagent inherits from +FS::Record. The following fields are currently supported: + +=over 4 + +=item groupagentnum - primary key + +=item groupnum - + +=item agentnum - + + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new group reseller virtualization. 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 + +# the new method can be inherited from FS::Record, if a table method is defined + +sub table { 'access_groupagent'; } + +=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 group reseller virtualization. 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('groupagentnum') + || $self->ut_foreign_key('groupnum', 'access_group', 'groupnum') + || $self->ut_foreign_key('agentnum', 'agent', 'agentnum') + ; + return $error if $error; + + $self->SUPER::check; +} + +=item agent + +Returns the associated FS::agent object. + +=cut + +sub agent { + my $self = shift; + qsearchs('agent', { 'agentnum' => $self->agentnum } ); +} + +=back + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/access_right.pm b/FS/FS/access_right.pm new file mode 100644 index 000000000..67200f245 --- /dev/null +++ b/FS/FS/access_right.pm @@ -0,0 +1,127 @@ +package FS::access_right; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::access_right - Object methods for access_right records + +=head1 SYNOPSIS + + use FS::access_right; + + $record = new FS::access_right \%hash; + $record = new FS::access_right { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::access_right object represents an example. FS::access_right inherits from +FS::Record. The following fields are currently supported: + +=over 4 + +=item rightnum - primary key + +=item righttype - + +=item rightobjnum - + +=item rightname - + + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new example. To add the example to the database, see L<"insert">. + +Note that this stores the hash reference, not a distinct copy of the hash it +points to. You can ask the object for a copy with the I<hash> method. + +=cut + +# the new method can be inherited from FS::Record, if a table method is defined + +sub table { 'access_right'; } + +=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('rightnum') + || $self->ut_text('righttype') + || $self->ut_text('rightobjnum') + || $self->ut_text('rightname') + ; + return $error if $error; + + $self->SUPER::check; +} + +=back + +=head1 BUGS + +The author forgot to customize this manpage. + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/access_user.pm b/FS/FS/access_user.pm new file mode 100644 index 000000000..cb43b37e9 --- /dev/null +++ b/FS/FS/access_user.pm @@ -0,0 +1,399 @@ +package FS::access_user; + +use strict; +use vars qw( @ISA $htpasswd_file ); +use FS::UID; +use FS::Conf; +use FS::Record qw( qsearch qsearchs dbh ); +use FS::m2m_Common; +use FS::option_Common; +use FS::access_usergroup; +use FS::agent; + +@ISA = qw( FS::m2m_Common FS::option_Common FS::Record ); +#@ISA = qw( FS::m2m_Common FS::option_Common ); + +#kludge htpasswd for now (i hope this bootstraps okay) +FS::UID->install_callback( sub { + my $conf = new FS::Conf; + $htpasswd_file = $conf->base_dir. '/htpasswd'; +} ); + +=head1 NAME + +FS::access_user - Object methods for access_user records + +=head1 SYNOPSIS + + use FS::access_user; + + $record = new FS::access_user \%hash; + $record = new FS::access_user { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::access_user object represents an internal access user. FS::access_user inherits from +FS::Record. The following fields are currently supported: + +=over 4 + +=item usernum - primary key + +=item username - + +=item _password - + +=item last - + +=item first - + +=item disabled - empty or 'Y' + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new internal access user. To add the user 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 { 'access_user'; } + +sub _option_table { 'access_user_pref'; } +sub _option_namecol { 'prefname'; } +sub _option_valuecol { 'prefvalue'; } + +=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->htpasswd_kludge(); + if ( $error ) { + $dbh->rollback or die $dbh->errstr if $oldAutoCommit; + return $error; + } + + $error = $self->SUPER::insert(@_); + + if ( $error ) { + $dbh->rollback or die $dbh->errstr if $oldAutoCommit; + return $error; + } else { + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; + } + +} + +sub htpasswd_kludge { + my $self = shift; + + #awful kludge to skip setting htpasswd for fs_* users + return '' if $self->username =~ /^fs_/; + + unshift @_, '-c' unless -e $htpasswd_file; + if ( + system('htpasswd', '-b', @_, + $htpasswd_file, + $self->username, + $self->_password, + ) == 0 + ) + { + return ''; + } else { + return 'htpasswd exited unsucessfully'; + } +} + +=item delete + +Delete this record from the database. + +=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(@_) + || $self->htpasswd_kludge('-D') + ; + + if ( $error ) { + $dbh->rollback or die $dbh->errstr if $oldAutoCommit; + return $error; + } else { + $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 + +sub replace { + my $new = shift; + + my $old = ( ref($_[0]) eq ref($new) ) + ? shift + : $new->replace_old; + + 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 ( $new->_password ne $old->_password ) { + my $error = $new->htpasswd_kludge(); + if ( $error ) { + $dbh->rollback or die $dbh->errstr if $oldAutoCommit; + return $error; + } + } + + my $error = $new->SUPER::replace($old, @_); + + if ( $error ) { + $dbh->rollback or die $dbh->errstr if $oldAutoCommit; + return $error; + } else { + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; + } + +} + +=item check + +Checks all fields to make sure this is a valid internal access user. 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('usernum') + || $self->ut_alpha('username') + || $self->ut_text('_password') + || $self->ut_text('last') + || $self->ut_text('first') + || $self->ut_enum('disabled', [ '', 'Y' ] ) + ; + return $error if $error; + + $self->SUPER::check; +} + +=item name + +Returns a name string for this user: "Last, First". + +=cut + +sub name { + my $self = shift; + $self->get('last'). ', '. $self->first; +} + +=item access_usergroup + +=cut + +sub access_usergroup { + my $self = shift; + qsearch( 'access_usergroup', { 'usernum' => $self->usernum } ); +} + +#=item access_groups +# +#=cut +# +#sub access_groups { +# +#} +# +#=item access_groupnames +# +#=cut +# +#sub access_groupnames { +# +#} + +=item agentnums + +Returns a list of agentnums this user can view (via group membership). + +=cut + +sub agentnums { + my $self = shift; + my $sth = dbh->prepare( + "SELECT DISTINCT agentnum FROM access_usergroup + JOIN access_groupagent USING ( groupnum ) + WHERE usernum = ?" + ) or die dbh->errstr; + $sth->execute($self->usernum) or die $sth->errstr; + map { $_->[0] } @{ $sth->fetchall_arrayref }; +} + +=item agentnums_href + +Returns a hashref of agentnums this user can view. + +=cut + +sub agentnums_href { + my $self = shift; + { map { $_ => 1 } $self->agentnums }; +} + +=item agentnums_sql + +Returns an sql fragement to select only agentnums this user can view. + +=cut + +sub agentnums_sql { + my $self = shift; + + my @agentnums = map { "agentnum = $_" } $self->agentnums; + + push @agentnums, 'agentnum IS NULL' + if $self->access_right('View/link unlinked services'); + + return ' 1 = 0 ' unless scalar(@agentnums); + '( '. join( ' OR ', @agentnums ). ' )'; +} + +=item agentnum + +Returns true if the user can view the specified agent. + +=cut + +sub agentnum { + my( $self, $agentnum ) = @_; + my $sth = dbh->prepare( + "SELECT COUNT(*) FROM access_usergroup + JOIN access_groupagent USING ( groupnum ) + WHERE usernum = ? AND agentnum = ?" + ) or die dbh->errstr; + $sth->execute($self->usernum, $agentnum) or die $sth->errstr; + $sth->fetchrow_arrayref->[0]; +} + +=item agents + +Returns the list of agents this user can view (via group membership), as +FS::agent objects. + +=cut + +sub agents { + my $self = shift; + qsearch({ + 'table' => 'agent', + 'hashref' => { disabled=>'' }, + 'extra_sql' => ' AND '. $self->agentnums_sql, + }); +} + +=item access_right + +Given a right name, returns true if this user has this right (currently via +group membership, eventually also via user overrides). + +=cut + +sub access_right { + my( $self, $rightname ) = @_; + my $sth = dbh->prepare(" + SELECT groupnum FROM access_usergroup + LEFT JOIN access_group USING ( groupnum ) + LEFT JOIN access_right + ON ( access_group.groupnum = access_right.rightobjnum ) + WHERE usernum = ? + AND righttype = 'FS::access_group' + AND rightname = ? + ") or die dbh->errstr; + $sth->execute($self->usernum, $rightname) or die $sth->errstr; + my $row = $sth->fetchrow_arrayref; + $row ? $row->[0] : ''; +} + +=back + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/access_user_pref.pm b/FS/FS/access_user_pref.pm new file mode 100644 index 000000000..ff957f2a1 --- /dev/null +++ b/FS/FS/access_user_pref.pm @@ -0,0 +1,127 @@ +package FS::access_user_pref; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::access_user_pref - Object methods for access_user_pref records + +=head1 SYNOPSIS + + use FS::access_user_pref; + + $record = new FS::access_user_pref \%hash; + $record = new FS::access_user_pref { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::access_user_pref object represents an example. FS::access_user_pref inherits from +FS::Record. The following fields are currently supported: + +=over 4 + +=item prefnum - primary key + +=item usernum - + +=item prefname - + +=item prefvalue - + + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new example. To add the example to the database, see L<"insert">. + +Note that this stores the hash reference, not a distinct copy of the hash it +points to. You can ask the object for a copy with the I<hash> method. + +=cut + +# the new method can be inherited from FS::Record, if a table method is defined + +sub table { 'access_user_pref'; } + +=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('prefnum') + || $self->ut_number('usernum') + || $self->ut_text('prefname') + || $self->ut_textn('prefvalue') + ; + return $error if $error; + + $self->SUPER::check; +} + +=back + +=head1 BUGS + +The author forgot to customize this manpage. + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/access_usergroup.pm b/FS/FS/access_usergroup.pm new file mode 100644 index 000000000..4d8836c15 --- /dev/null +++ b/FS/FS/access_usergroup.pm @@ -0,0 +1,144 @@ +package FS::access_usergroup; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); +use FS::access_user; +use FS::access_group; + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::access_usergroup - Object methods for access_usergroup records + +=head1 SYNOPSIS + + use FS::access_usergroup; + + $record = new FS::access_usergroup \%hash; + $record = new FS::access_usergroup { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::access_usergroup object represents an example. FS::access_usergroup inherits from +FS::Record. The following fields are currently supported: + +=over 4 + +=item usergroupnum - primary key + +=item usernum - + +=item groupnum - + + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new example. To add the example to the database, see L<"insert">. + +Note that this stores the hash reference, not a distinct copy of the hash it +points to. You can ask the object for a copy with the I<hash> method. + +=cut + +# the new method can be inherited from FS::Record, if a table method is defined + +sub table { 'access_usergroup'; } + +=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('usergroupnum') + || $self->ut_number('usernum') + || $self->ut_number('groupnum') + ; + return $error if $error; + + $self->SUPER::check; +} + +=item access_user + +=cut + +sub access_user { + my $self = shift; + qsearchs( 'access_user', { 'usernum' => $self->usernum } ); +} + +=item access_group + +=cut + +sub access_group { + my $self = shift; + qsearchs( 'access_group', { 'groupnum' => $self->groupnum } ); +} + +=back + +=head1 BUGS + +The author forgot to customize this manpage. + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/agent.pm b/FS/FS/agent.pm index 83f0ce5b5..e40ef09db 100644 --- a/FS/FS/agent.pm +++ b/FS/FS/agent.pm @@ -195,7 +195,7 @@ sub num_sql { my( $self, $sql ) = @_; my $statement = "SELECT COUNT(*) FROM cust_main WHERE agentnum = ? AND $sql"; my $sth = dbh->prepare($statement) or die dbh->errstr." preparing $statement"; - $sth->execute($self->agentnum) or die $sth->errstr. "executing $statement"; + $sth->execute($self->agentnum) or die $sth->errstr. " executing $statement"; $sth->fetchrow_arrayref->[0]; } @@ -221,7 +221,8 @@ sub cust_main_sql { =item num_active_cust_main -Returns the number of active customers for this agent. +Returns the number of active customers for this agent (customers with active +recurring packages). =cut @@ -239,6 +240,28 @@ sub active_cust_main { shift->cust_main_sql(FS::cust_main->active_sql); } +=item num_inactive_cust_main + +Returns the number of inactive customers for this agent (customers with no +active recurring packages, but otherwise unsuspended/uncancelled). + +=cut + +sub num_inactive_cust_main { + shift->num_sql(FS::cust_main->inactive_sql); +} + +=item inactive_cust_main + +Returns the inactive customers for this agent, as cust_main objects. + +=cut + +sub inactive_cust_main { + shift->cust_main_sql(FS::cust_main->inactive_sql); +} + + =item num_susp_cust_main Returns the number of suspended customers for this agent. @@ -299,6 +322,17 @@ sub num_pkg_sql { $sth->fetchrow_arrayref->[0]; } +=item num_inactive_cust_pkg + +Returns the number of inactive customer packages (one-time packages otherwise +unsuspended/uncancelled) for this agent. + +=cut + +sub num_inactive_cust_pkg { + shift->num_pkg_sql(FS::cust_pkg->inactive_sql); +} + =item num_susp_cust_pkg Returns the number of suspended customer packages for this agent. diff --git a/FS/FS/agent_type.pm b/FS/FS/agent_type.pm index 968b3b72e..2660bb4a3 100644 --- a/FS/FS/agent_type.pm +++ b/FS/FS/agent_type.pm @@ -3,10 +3,11 @@ package FS::agent_type; use strict; use vars qw( @ISA ); use FS::Record qw( qsearch ); +use FS::m2m_Common; use FS::agent; use FS::type_pkgs; -@ISA = qw( FS::Record ); +@ISA = qw( FS::m2m_Common FS::Record ); =head1 NAME @@ -135,6 +136,27 @@ sub type_pkgs { qsearch('type_pkgs', { 'typenum' => $self->typenum } ); } +=item type_pkgs_enabled + +Returns all FS::type_pkg objects (see L<FS::type_pkgs>) that link to enabled +package definitions (see L<FS::part_pkg>). + +An additional strange feature is that the returned type_pkg objects also have +all fields of the associated part_pkg object. + +=cut + +sub type_pkgs_enabled { + my $self = shift; + qsearch({ + 'table' => 'type_pkgs', + 'addl_from' => 'JOIN part_pkg USING ( pkgpart )', + 'hashref' => { 'typenum' => $self->typenum }, + 'extra_sql' => " AND ( disabled = '' OR disabled IS NULL )". + " ORDER BY pkg", + }); +} + =item pkgpart Returns the pkgpart of all package definitions (see L<FS::part_pkg>) for this @@ -151,6 +173,13 @@ sub pkgpart { =head1 BUGS +type_pkgs_enabled should order itself by something (pkg?) + +type_pkgs_enabled should populate something that caches for the part_pkg method +rather than add fields to this object, right? In fact we need a "poop" object +framework that does that automatically for any joined search at some point.... +right? + =head1 SEE ALSO L<FS::Record>, L<FS::agent>, L<FS::type_pkgs>, L<FS::cust_main>, diff --git a/FS/FS/cdr.pm b/FS/FS/cdr.pm new file mode 100644 index 000000000..bddd1bf51 --- /dev/null +++ b/FS/FS/cdr.pm @@ -0,0 +1,640 @@ +package FS::cdr; + +use strict; +use vars qw( @ISA ); +use Date::Parse; +use Date::Format; +use Time::Local; +use FS::UID qw( dbh ); +use FS::Record qw( qsearch qsearchs ); +use FS::cdr_type; +use FS::cdr_calltype; +use FS::cdr_carrier; +use FS::cdr_upstream_rate; + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::cdr - Object methods for cdr records + +=head1 SYNOPSIS + + use FS::cdr; + + $record = new FS::cdr \%hash; + $record = new FS::cdr { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::cdr object represents an Call Data Record, typically from a telephony +system or provider of some sort. FS::cdr inherits from FS::Record. The +following fields are currently supported: + +=over 4 + +=item acctid - primary key + +=item calldate - Call timestamp (SQL timestamp) + +=item clid - Caller*ID with text + +=item src - Caller*ID number / Source number + +=item dst - Destination extension + +=item dcontext - Destination context + +=item channel - Channel used + +=item dstchannel - Destination channel if appropriate + +=item lastapp - Last application if appropriate + +=item lastdata - Last application data + +=item startdate - Start of call (UNIX-style integer timestamp) + +=item answerdate - Answer time of call (UNIX-style integer timestamp) + +=item enddate - End time of call (UNIX-style integer timestamp) + +=item duration - Total time in system, in seconds + +=item billsec - Total time call is up, in seconds + +=item disposition - What happened to the call: ANSWERED, NO ANSWER, BUSY + +=item amaflags - What flags to use: BILL, IGNORE etc, specified on a per channel basis like accountcode. + +=cut + + #ignore the "omit" and "documentation" AMAs?? + #AMA = Automated Message Accounting. + #default: Sets the system default. + #omit: Do not record calls. + #billing: Mark the entry for billing + #documentation: Mark the entry for documentation. + +=item accountcode - CDR account number to use: account + +=item uniqueid - Unique channel identifier (Unitel/RSLCOM Event ID) + +=item userfield - CDR user-defined field + +=item cdr_type - CDR type - see L<FS::cdr_type> (Usage = 1, S&E = 7, OC&C = 8) + +=item charged_party - Service number to be billed + +=item upstream_currency - Wholesale currency from upstream + +=item upstream_price - Wholesale price from upstream + +=item upstream_rateplanid - Upstream rate plan ID + +=item rated_price - Rated (or re-rated) price + +=item distance - km (need units field?) + +=item islocal - Local - 1, Non Local = 0 + +=item calltypenum - Type of call - see L<FS::cdr_calltype> + +=item description - Description (cdr_type 7&8 only) (used for cust_bill_pkg.itemdesc) + +=item quantity - Number of items (cdr_type 7&8 only) + +=item carrierid - Upstream Carrier ID (see L<FS::cdr_carrier>) + +=cut + +#Telstra =1, Optus = 2, RSL COM = 3 + +=item upstream_rateid - Upstream Rate ID + +=item svcnum - Link to customer service (see L<FS::cust_svc>) + +=item freesidestatus - NULL, done (or something) + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new CDR. To add the CDR 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 { 'cdr'; } + +=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 CDR. If there is +an error, returns the error, otherwise returns false. Called by the insert +and replace methods. + +Note: Unlike most types of records, we don't want to "reject" a CDR and we want +to process them as quickly as possible, so we allow the database to check most +of the data. + +=cut + +sub check { + my $self = shift; + +# we don't want to "reject" a CDR like other sorts of input... +# my $error = +# $self->ut_numbern('acctid') +## || $self->ut_('calldate') +# || $self->ut_text('clid') +# || $self->ut_text('src') +# || $self->ut_text('dst') +# || $self->ut_text('dcontext') +# || $self->ut_text('channel') +# || $self->ut_text('dstchannel') +# || $self->ut_text('lastapp') +# || $self->ut_text('lastdata') +# || $self->ut_numbern('startdate') +# || $self->ut_numbern('answerdate') +# || $self->ut_numbern('enddate') +# || $self->ut_number('duration') +# || $self->ut_number('billsec') +# || $self->ut_text('disposition') +# || $self->ut_number('amaflags') +# || $self->ut_text('accountcode') +# || $self->ut_text('uniqueid') +# || $self->ut_text('userfield') +# || $self->ut_numbern('cdrtypenum') +# || $self->ut_textn('charged_party') +## || $self->ut_n('upstream_currency') +## || $self->ut_n('upstream_price') +# || $self->ut_numbern('upstream_rateplanid') +## || $self->ut_n('distance') +# || $self->ut_numbern('islocal') +# || $self->ut_numbern('calltypenum') +# || $self->ut_textn('description') +# || $self->ut_numbern('quantity') +# || $self->ut_numbern('carrierid') +# || $self->ut_numbern('upstream_rateid') +# || $self->ut_numbern('svcnum') +# || $self->ut_textn('freesidestatus') +# ; +# return $error if $error; + + $self->calldate( $self->startdate_sql ) + if !$self->calldate && $self->startdate; + + unless ( $self->charged_party ) { + if ( $self->dst =~ /^(\+?1)?8[02-8]{2}/ ) { + $self->charged_party($self->dst); + } else { + $self->charged_party($self->src); + } + } + + #check the foreign keys even? + #do we want to outright *reject* the CDR? + my $error = + $self->ut_numbern('acctid') + + #Usage = 1, S&E = 7, OC&C = 8 + || $self->ut_foreign_keyn('cdrtypenum', 'cdr_type', 'cdrtypenum' ) + + #the big list in appendix 2 + || $self->ut_foreign_keyn('calltypenum', 'cdr_calltype', 'calltypenum' ) + + # Telstra =1, Optus = 2, RSL COM = 3 + || $self->ut_foreign_keyn('carrierid', 'cdr_carrier', 'carrierid' ) + ; + return $error if $error; + + $self->SUPER::check; +} + +=item set_status_and_rated_price STATUS [ RATED_PRICE ] + +Sets the status to the provided string. If there is an error, returns the +error, otherwise returns false. + +=cut + +sub set_status_and_rated_price { + my($self, $status, $rated_price) = @_; + $self->freesidestatus($status); + $self->rated_price($rated_price); + $self->replace(); +} + +=item calldate_unix + +Parses the calldate in SQL string format and returns a UNIX timestamp. + +=cut + +sub calldate_unix { + str2time(shift->calldate); +} + +=item startdate_sql + +Parses the startdate in UNIX timestamp format and returns a string in SQL +format. + +=cut + +sub startdate_sql { + my($sec,$min,$hour,$mday,$mon,$year) = localtime(shift->startdate); + $mon++; + $year += 1900; + "$year-$mon-$mday $hour:$min:$sec"; +} + +=item cdr_carrier + +Returns the FS::cdr_carrier object associated with this CDR, or false if no +carrierid is defined. + +=cut + +my %carrier_cache = (); + +sub cdr_carrier { + my $self = shift; + return '' unless $self->carrierid; + $carrier_cache{$self->carrierid} ||= + qsearchs('cdr_carrier', { 'carrierid' => $self->carrierid } ); +} + +=item carriername + +Returns the carrier name (see L<FS::cdr_carrier>), or the empty string if +no FS::cdr_carrier object is assocated with this CDR. + +=cut + +sub carriername { + my $self = shift; + my $cdr_carrier = $self->cdr_carrier; + $cdr_carrier ? $cdr_carrier->carriername : ''; +} + +=item cdr_calltype + +Returns the FS::cdr_calltype object associated with this CDR, or false if no +calltypenum is defined. + +=cut + +my %calltype_cache = (); + +sub cdr_calltype { + my $self = shift; + return '' unless $self->calltypenum; + $calltype_cache{$self->calltypenum} ||= + qsearchs('cdr_calltype', { 'calltypenum' => $self->calltypenum } ); +} + +=item calltypename + +Returns the call type name (see L<FS::cdr_calltype>), or the empty string if +no FS::cdr_calltype object is assocated with this CDR. + +=cut + +sub calltypename { + my $self = shift; + my $cdr_calltype = $self->cdr_calltype; + $cdr_calltype ? $cdr_calltype->calltypename : ''; +} + +=item cdr_upstream_rate + +Returns the upstream rate mapping (see L<FS::cdr_upstream_rate>), or the empty +string if no FS::cdr_upstream_rate object is associated with this CDR. + +=cut + +sub cdr_upstream_rate { + my $self = shift; + return '' unless $self->upstream_rateid; + qsearchs('cdr_upstream_rate', { 'upstream_rateid' => $self->upstream_rateid }) + or ''; +} + +=item _convergent_format COLUMN [ COUNTRYCODE ] + +Returns the number in COLUMN formatted as follows: + +If the country code does not match COUNTRYCODE (default "61"), it is returned +unchanged. + +If the country code does match COUNTRYCODE (default "61"), it is removed. In +addiiton, "0" is prepended unless the number starts with 13, 18 or 19. (???) + +=cut + +sub _convergent_format { + my( $self, $field ) = ( shift, shift ); + my $countrycode = scalar(@_) ? shift : '61'; #+61 = australia + #my $number = $self->$field(); + my $number = $self->get($field); + #if ( $number =~ s/^(\+|011)$countrycode// ) { + if ( $number =~ s/^\+$countrycode// ) { + $number = "0$number" + unless $number =~ /^1[389]/; #??? + } + $number; +} + +=item downstream_csv [ OPTION => VALUE, ... ] + +=cut + +my %export_formats = ( + 'convergent' => [ + 'carriername', #CARRIER + sub { shift->_convergent_format('src') }, #SERVICE_NUMBER + sub { shift->_convergent_format('charged_party') }, #CHARGED_NUMBER + sub { time2str('%Y-%m-%d', shift->calldate_unix ) }, #DATE + sub { time2str('%T', shift->calldate_unix ) }, #TIME + 'billsec', #'duration', #DURATION + sub { shift->_convergent_format('dst') }, #NUMBER_DIALED + '', #XXX add (from prefixes in most recent email) #FROM_DESC + '', #XXX add (from prefixes in most recent email) #TO_DESC + 'calltypename', #CLASS_CODE + 'rated_price', #PRICE + sub { shift->rated_price ? 'Y' : 'N' }, #RATED + '', #OTHER_INFO + ], +); + +sub downstream_csv { + my( $self, %opt ) = @_; + + my $format = $opt{'format'}; # 'convergent'; + return "Unknown format $format" unless exists $export_formats{$format}; + + eval "use Text::CSV_XS;"; + die $@ if $@; + my $csv = new Text::CSV_XS; + + my @columns = + map { + ref($_) ? &{$_}($self) : $self->$_(); + } + @{ $export_formats{$format} }; + + my $status = $csv->combine(@columns); + die "FS::CDR: error combining ". $csv->error_input(). "into downstream CSV" + unless $status; + + $csv->string; + +} + +=back + +=head1 CLASS METHODS + +=over 4 + +=item batch_import + +=cut + +my($tmp_mday, $tmp_mon, $tmp_year); + +my %import_formats = ( + 'asterisk' => [ + 'accountcode', + 'src', + 'dst', + 'dcontext', + 'clid', + 'channel', + 'dstchannel', + 'lastapp', + 'lastdata', + 'startdate', # XXX will need massaging + 'answer', # XXX same + 'end', # XXX same + 'duration', + 'billsec', + 'disposition', + 'amaflags', + 'uniqueid', + 'userfield', + ], + 'unitel' => [ + 'uniqueid', + #'cdr_type', + 'cdrtypenum', + 'calldate', # may need massaging? huh maybe not... + #'billsec', #XXX duration and billsec? + sub { $_[0]->billsec( $_[1] ); + $_[0]->duration( $_[1] ); + }, + 'src', + 'dst', # XXX needs to have "+61" prepended unless /^\+/ ??? + 'charged_party', + 'upstream_currency', + 'upstream_price', + 'upstream_rateplanid', + 'distance', + 'islocal', + 'calltypenum', + 'startdate', #XXX needs massaging + 'enddate', #XXX same + 'description', + 'quantity', + 'carrierid', + 'upstream_rateid', + ], + 'ams' => [ + + # Date + sub { my($cdr, $date) = @_; + $date =~ /^(\d{1,2})\/(\d{1,2})\/(\d\d(\d\d)?)$/ + or die "unparsable date: $date"; #maybe we shouldn't die... + #$cdr->startdate( timelocal(0, 0, 0 ,$2, $1-1, $3) ); + ($tmp_mday, $tmp_mon, $tmp_year) = ( $2, $1-1, $3 ); + }, + + # Time + sub { my($cdr, $time) = @_; + #my($sec, $min, $hour, $mday, $mon, $year)= localtime($cdr->startdate); + $time =~ /^(\d{1,2}):(\d{1,2}):(\d{1,2})$/ + or die "unparsable time: $time"; #maybe we shouldn't die... + #$cdr->startdate( timelocal($3, $2, $1 ,$mday, $mon, $year) ); + $cdr->startdate( + timelocal($3, $2, $1 ,$tmp_mday, $tmp_mon, $tmp_year) + ); + }, + + # Source_Number + 'src', + + # Terminating_Number + 'dst', + + # Duration + sub { my($cdr, $min) = @_; + my $sec = sprintf('%.0f', $min * 60 ); + $cdr->billsec( $sec ); + $cdr->duration( $sec ); + }, + + ], +); + +sub batch_import { + my $param = shift; + + my $fh = $param->{filehandle}; + my $format = $param->{format}; + + return "Unknown format $format" unless exists $import_formats{$format}; + + eval "use Text::CSV_XS;"; + die $@ if $@; + + my $csv = new Text::CSV_XS; + + my $imported = 0; + #my $columns; + + 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 ( $format eq 'ams' ) { # and other formats with a header too? + + } + + my $body = 0; + my $line; + while ( defined($line=<$fh>) ) { + + #skip header... + if ( ! $body++ && $format eq 'ams' && $line =~ /^[\w\, ]+$/ ) { + next; + } + + $csv->parse($line) or do { + $dbh->rollback if $oldAutoCommit; + return "can't parse: ". $csv->error_input(); + }; + + my @columns = $csv->fields(); + #warn join('-',@columns); + + if ( $format eq 'ams' ) { + @columns = map { s/^ +//; $_; } @columns; + } + + my @later = (); + my %cdr = + map { + + my $field_or_sub = $_; + if ( ref($field_or_sub) ) { + push @later, $field_or_sub, shift(@columns); + (); + } else { + ( $field_or_sub => shift @columns ); + } + + } + @{ $import_formats{$format} } + ; + + my $cdr = new FS::cdr ( \%cdr ); + + while ( scalar(@later) ) { + my $sub = shift @later; + my $data = shift @later; + &{$sub}($cdr, $data); # $cdr->&{$sub}($data); + } + + my $error = $cdr->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + + #or just skip? + #next; + } + + $imported++; + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + #might want to disable this if we skip records for any reason... + return "Empty file!" unless $imported; + + ''; + +} + +=back + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/cdr_calltype.pm b/FS/FS/cdr_calltype.pm new file mode 100644 index 000000000..fe456086f --- /dev/null +++ b/FS/FS/cdr_calltype.pm @@ -0,0 +1,115 @@ +package FS::cdr_calltype; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::cdr_calltype - Object methods for cdr_calltype records + +=head1 SYNOPSIS + + use FS::cdr_calltype; + + $record = new FS::cdr_calltype \%hash; + $record = new FS::cdr_calltype { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::cdr_calltype object represents an CDR call type. FS::cdr_calltype +inherits from FS::Record. The following fields are currently supported: + +=over 4 + +=item calltypenum - primary key + +=item calltypename - CDR call type name + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new call type. To add the call type 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 { 'cdr_calltype'; } + +=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 call 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; + + my $error = + $self->ut_numbern('calltypenum') + || $self->ut_text('calltypename') + ; + return $error if $error; + + $self->SUPER::check; +} + +=back + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/cdr_carrier.pm b/FS/FS/cdr_carrier.pm new file mode 100644 index 000000000..609c93923 --- /dev/null +++ b/FS/FS/cdr_carrier.pm @@ -0,0 +1,116 @@ +package FS::cdr_carrier; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::cdr_carrier - Object methods for cdr_carrier records + +=head1 SYNOPSIS + + use FS::cdr_carrier; + + $record = new FS::cdr_carrier \%hash; + $record = new FS::cdr_carrier { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::cdr_carrier object represents an CDR carrier or upstream. +FS::cdr_carrier inherits from FS::Record. The following fields are currently +supported: + +=over 4 + +=item carrierid - primary key + +=item carriername - Carrier name + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new carrier. To add the carrier 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 { 'cdr_carrier'; } + +=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 carrier. 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('carrierid') + || $self->ut_text('carriername') + ; + return $error if $error; + + $self->SUPER::check; +} + +=back + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/cancel_reason.pm b/FS/FS/cdr_type.pm index 19cc7214e..e258bf878 100644 --- a/FS/FS/cancel_reason.pm +++ b/FS/FS/cdr_type.pm @@ -1,4 +1,4 @@ -package FS::cancel_reason; +package FS::cdr_type; use strict; use vars qw( @ISA ); @@ -8,14 +8,14 @@ use FS::Record qw( qsearch qsearchs ); =head1 NAME -FS::cancel_reason - Object methods for cancel_reason records +FS::cdr_type - Object methods for cdr_type records =head1 SYNOPSIS - use FS::cancel_reason; + use FS::cdr_type; - $record = new FS::cancel_reason \%hash; - $record = new FS::cancel_reason { 'column' => 'value' }; + $record = new FS::cdr_type \%hash; + $record = new FS::cdr_type { 'column' => 'value' }; $error = $record->insert; @@ -27,17 +27,15 @@ FS::cancel_reason - Object methods for cancel_reason records =head1 DESCRIPTION -An FS::cancel_reason object represents an cancellation reason. -FS::cancel_reason inherits from FS::Record. The following fields are -currently supported: +An FS::cdr_type object represents an CDR type. FS::cdr_type inherits from +FS::Record. The following fields are currently supported: =over 4 -=item reasonnum - primary key +=item cdrtypenum - primary key -=item reason - +=item typename - CDR type name -=item disabled - empty or "Y" =back @@ -47,8 +45,7 @@ currently supported: =item new HASHREF -Creates a new cancellation reason. To add the reason to the database, see -L<"insert">. +Creates a new CDR type. To add the CDR type 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. @@ -57,7 +54,7 @@ points to. You can ask the object for a copy with the I<hash> method. # the new method can be inherited from FS::Record, if a table method is defined -sub table { 'cancel_reason'; } +sub table { 'cdr_type'; } =item insert @@ -87,7 +84,7 @@ returns the error, otherwise returns false. =item check -Checks all fields to make sure this is a valid reason. If there is +Checks all fields to make sure this is a valid CDR type. If there is an error, returns the error, otherwise returns false. Called by the insert and replace methods. @@ -100,9 +97,8 @@ sub check { my $self = shift; my $error = - $self->ut_numbern('reasonnum') - || $self->ut_text('reason') - || $self->ut_enum('disabled', [ '', 'Y' ] ) + $self->ut_numbern('cdrtypenum') + || $self->ut_text('typename') ; return $error if $error; diff --git a/FS/FS/cdr_upstream_rate.pm b/FS/FS/cdr_upstream_rate.pm new file mode 100644 index 000000000..2fd978203 --- /dev/null +++ b/FS/FS/cdr_upstream_rate.pm @@ -0,0 +1,138 @@ +package FS::cdr_upstream_rate; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); +use FS::rate_detail; + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::cdr_upstream_rate - Object methods for cdr_upstream_rate records + +=head1 SYNOPSIS + + use FS::cdr_upstream_rate; + + $record = new FS::cdr_upstream_rate \%hash; + $record = new FS::cdr_upstream_rate { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::cdr_upstream_rate object represents an upstream rate mapping to +internal rate detail (see L<FS::rate_detail>). FS::cdr_upstream_rate inherits +from FS::Record. The following fields are currently supported: + +=over 4 + +=item upstreamratenum - primary key + +=item upstream_rateid - CDR upstream Rate ID (cdr.upstream_rateid - see L<FS::cdr>) + +=item ratedetailnum - Rate detail - see L<FS::rate_detail> + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new upstream rate mapping. To add the upstream rate 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 { 'cdr_upstream_rate'; } + +=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 upstream rate. 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('upstreamratenum') + #|| $self->ut_number('upstream_rateid') + || $self->ut_alpha('upstream_rateid') + #|| $self->ut_text('upstream_rateid') + || $self->ut_foreign_key('ratedetailnum', 'rate_detail', 'ratedetailnum' ) + ; + return $error if $error; + + $self->SUPER::check; +} + +=item rate_detail + +Returns the internal rate detail object for this upstream rate (see +L<FS::rate_detail>). + +=cut + +sub rate_detail { + my $self = shift; + qsearchs('rate_detail', { 'ratedetailnum' => $self->ratedetailnum } ); +} + +=back + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/cust_bill.pm b/FS/FS/cust_bill.pm index 6e3b2b2f8..2c0b35388 100644 --- a/FS/FS/cust_bill.pm +++ b/FS/FS/cust_bill.pm @@ -1,9 +1,10 @@ package FS::cust_bill; use strict; -use vars qw( @ISA $DEBUG $conf $money_char ); +use vars qw( @ISA $DEBUG $me $conf $money_char ); use vars qw( $invoice_lines @buf ); #yuck use Fcntl qw(:flock); #for spool_csv +use List::Util qw(min max); use IPC::Run3; use Date::Format; use Text::Template 1.20; @@ -13,7 +14,7 @@ use HTML::Entities; use Locale::Country; use FS::UID qw( datasrc ); use FS::Misc qw( send_email send_fax ); -use FS::Record qw( qsearch qsearchs ); +use FS::Record qw( qsearch qsearchs dbh ); use FS::cust_main_Mixin; use FS::cust_main; use FS::cust_bill_pkg; @@ -21,15 +22,19 @@ use FS::cust_credit; use FS::cust_pay; use FS::cust_pkg; use FS::cust_credit_bill; +use FS::pay_batch; use FS::cust_pay_batch; use FS::cust_bill_event; use FS::part_pkg; use FS::cust_bill_pay; +use FS::cust_bill_pay_batch; use FS::part_bill_event; +use FS::payby; @ISA = qw( FS::cust_main_Mixin FS::Record ); $DEBUG = 0; +$me = '[FS::cust_bill]'; #ask FS::UID to run this stuff for us later FS::UID->install_callback( sub { @@ -121,8 +126,14 @@ 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?) +This method now works but you probably shouldn't use it. Instead, apply a +credit against the invoice. + +Using this method to delete invoices outright is really, really bad. There +would be no record you ever posted this invoice, and there are no check to +make sure charged = 0 or that there are no associated cust_bill_pkg records. + +Really, don't use it. =cut @@ -142,14 +153,20 @@ collect method of a customer object (see L<FS::cust_main>). =cut -sub replace { +#replace can be inherited from Record.pm + +# replace_check is now the preferred way to #implement replace data checks +# (so $object->replace() works without an argument) + +sub replace_check { my( $new, $old ) = ( shift, shift ); return "Can't change custnum!" unless $old->custnum == $new->custnum; #return "Can't change _date!" unless $old->_date eq $new->_date; return "Can't change _date!" unless $old->_date == $new->_date; - return "Can't change charged!" unless $old->charged == $new->charged; + return "Can't change charged!" unless $old->charged == $new->charged + || $old->charged == 0; - $new->SUPER::replace($old); + ''; } =item check @@ -212,6 +229,47 @@ sub cust_bill_pkg { qsearch( 'cust_bill_pkg', { 'invnum' => $self->invnum } ); } +=item cust_pkg + +Returns the packages (see L<FS::cust_pkg>) corresponding to the line items for +this invoice. + +=cut + +sub cust_pkg { + my $self = shift; + my @cust_pkg = map { $_->cust_pkg } $self->cust_bill_pkg; + my %saw = (); + grep { ! $saw{$_->pkgnum}++ } @cust_pkg; +} + +=item open_cust_bill_pkg + +Returns the open line items for this invoice. + +Note that cust_bill_pkg with both setup and recur fees are returned as two +separate line items, each with only one fee. + +=cut + +# modeled after cust_main::open_cust_bill +sub open_cust_bill_pkg { + my $self = shift; + + # grep { $_->owed > 0 } $self->cust_bill_pkg + + my %other = ( 'recur' => 'setup', + 'setup' => 'recur', ); + my @open = (); + foreach my $field ( qw( recur setup )) { + push @open, map { $_->set( $other{$field}, 0 ); $_; } + grep { $_->owed($field) > 0 } + $self->cust_bill_pkg; + } + + @open; +} + =item cust_bill_event Returns the completed invoice events (see L<FS::cust_bill_event>) for this @@ -251,7 +309,7 @@ sub cust_suspend_if_balance_over { if ( $cust_main->total_owed_date($self->_date) < $amount ) { return (); } else { - $cust_main->suspend; + $cust_main->suspend(@_); } } @@ -354,6 +412,79 @@ sub owed { $balance; } +=item apply_payments_and_credits + +=cut + +sub apply_payments_and_credits { + my $self = shift; + + my @payments = grep { $_->unapplied > 0 } $self->cust_main->cust_pay; + my @credits = grep { $_->credited > 0 } $self->cust_main->cust_credit; + + while ( $self->owed > 0 and ( @payments || @credits ) ) { + + my $app = ''; + if ( @payments && @credits ) { + + #decide which goes first by weight of top (unapplied) line item + + my @open_lineitems = $self->open_cust_bill_pkg; + + my $max_pay_weight = + max( map { $_->cust_pkg->part_pkg->pay_weight || 0 } + @open_lineitems + ); + my $max_credit_weight = + max( map { $_->cust_pkg->part_pkg->credit_weight || 0 } + @open_lineitems + ); + + #if both are the same... payments first? it has to be something + if ( $max_pay_weight >= $max_credit_weight ) { + $app = 'pay'; + } else { + $app = 'credit'; + } + + } elsif ( @payments ) { + $app = 'pay'; + } elsif ( @credits ) { + $app = 'credit'; + } else { + die "guru meditation #12 and 35"; + } + + if ( $app eq 'pay' ) { + + my $payment = shift @payments; + + $app = new FS::cust_bill_pay { + 'paynum' => $payment->paynum, + 'amount' => sprintf('%.2f', min( $payment->unapplied, $self->owed ) ), + }; + + } elsif ( $app eq 'credit' ) { + + my $credit = shift @credits; + + $app = new FS::cust_credit_bill { + 'crednum' => $credit->crednum, + 'amount' => sprintf('%.2f', min( $credit->credited, $self->owed ) ), + }; + + } else { + die "guru meditation #12 and 35"; + } + + $app->invnum( $self->invnum ); + + my $error = $app->insert; + die $error if $error; + + } + +} =item generate_email PARAMHASH @@ -440,16 +571,17 @@ sub generate_email { 'Disposition' => 'inline', ); - $args{'from'} =~ /\@([\w\.\-]+)/ or $1 = 'example.com'; - my $content_id = join('.', rand()*(2**32), $$, time). "\@$1"; + $args{'from'} =~ /\@([\w\.\-]+)/; + my $from = $1 || 'example.com'; + my $content_id = join('.', rand()*(2**32), $$, time). "\@$from"; my $path = "$FS::UID::conf_dir/conf.$FS::UID::datasrc"; my $file; - if ( defined($args{'_template'}) && length($args{'_template'}) - && -e "$path/logo_". $args{'_template'}. ".png" + if ( defined($args{'template'}) && length($args{'template'}) + && -e "$path/logo_". $args{'template'}. ".png" ) { - $file = "$path/logo_". $args{'_template'}. ".png"; + $file = "$path/logo_". $args{'template'}. ".png"; } else { $file = "$path/logo.png"; } @@ -597,6 +729,21 @@ INVOICE_FROM, if specified, overrides the default email invoice From: address. =cut +sub queueable_send { + my %opt = @_; + + my $self = qsearchs('cust_bill', { 'invnum' => $opt{invnum} } ) + or die "invalid invoice number: " . $opt{invnum}; + + my @args = ( $opt{template}, $opt{agentnum} ); + push @args, $opt{invoice_from} + if exists($opt{invoice_from}) && $opt{invoice_from}; + + my $error = $self->send( @args ); + die $error if $error; + +} + sub send { my $self = shift; my $template = scalar(@_) ? shift : ''; @@ -635,6 +782,21 @@ INVOICE_FROM, if specified, overrides the default email invoice From: address. =cut +sub queueable_email { + my %opt = @_; + + my $self = qsearchs('cust_bill', { 'invnum' => $opt{invnum} } ) + or die "invalid invoice number: " . $opt{invnum}; + + my @args = ( $opt{template} ); + push @args, $opt{invoice_from} + if exists($opt{invoice_from}) && $opt{invoice_from}; + + my $error = $self->email( @args ); + die $error if $error; + +} + sub email { my $self = shift; my $template = scalar(@_) ? shift : ''; @@ -824,6 +986,8 @@ Options are: =item agent_spools - if set to a true value, will spool to per-agent files rather than a single global file +=item balanceover - if set, only spools the invoice if the total amount owed on this invoice and all older invoices is greater than the specified amount. + =back =cut @@ -840,6 +1004,11 @@ sub spool_csv { || ! keys %invoicing_list; } + if ( $opt{'balanceover'} ) { + return 'N/A' + if $cust_main->total_owed_date($self->_date) < $opt{'balanceover'}; + } + my $spooldir = "/usr/local/etc/freeside/export.". datasrc. "/cust_bill"; mkdir $spooldir, 0700 unless -d $spooldir; @@ -1253,36 +1422,118 @@ sub realtime_bop { } -=item batch_card +=item batch_card OPTION => VALUE... Adds a payment for this invoice to the pending credit card batch (see -L<FS::cust_pay_batch>). +L<FS::cust_pay_batch>), or, if the B<realtime> option is set to a true value, +runs the payment using a realtime gateway. =cut sub batch_card { - my $self = shift; + my ($self, %options) = @_; my $cust_main = $self->cust_main; + my $amount = sprintf("%.2f", $cust_main->balance - $cust_main->in_transit_payments); + return '' unless $amount > 0; + + if ($options{'realtime'}) { + return $cust_main->realtime_bop( FS::payby->payby2bop($cust_main->payby), + $amount, + %options, + ); + } + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + $dbh->do("LOCK TABLE pay_batch IN SHARE ROW EXCLUSIVE MODE") + or return "Cannot lock pay_batch: " . $dbh->errstr; + + my %pay_batch = ( + 'status' => 'O', + 'payby' => FS::payby->payby2payment($cust_main->payby), + ); + + my $pay_batch = qsearchs( 'pay_batch', \%pay_batch ); + + unless ( $pay_batch ) { + $pay_batch = new FS::pay_batch \%pay_batch; + my $error = $pay_batch->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + die "error creating new batch: $error\n"; + } + } + + my $old_cust_pay_batch = qsearchs('cust_pay_batch', { + 'batchnum' => $pay_batch->batchnum, + 'custnum' => $cust_main->custnum, + } ); + my $cust_pay_batch = new FS::cust_pay_batch ( { - 'invnum' => $self->getfield('invnum'), - 'custnum' => $cust_main->getfield('custnum'), + 'batchnum' => $pay_batch->batchnum, + 'invnum' => $self->getfield('invnum'), # is there a better value? + # this field should be + # removed... + # cust_bill_pay_batch now + 'custnum' => $cust_main->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'), - 'cardnum' => $cust_main->payinfo, - 'exp' => $cust_main->getfield('paydate'), - 'payname' => $cust_main->getfield('payname'), - 'amount' => $self->owed, + 'address1' => $cust_main->address1, + 'address2' => $cust_main->address2, + 'city' => $cust_main->city, + 'state' => $cust_main->state, + 'zip' => $cust_main->zip, + 'country' => $cust_main->country, + 'payby' => $cust_main->payby, + 'payinfo' => $cust_main->payinfo, + 'exp' => $cust_main->paydate, + 'payname' => $cust_main->payname, + 'amount' => $amount, # consolidating } ); - my $error = $cust_pay_batch->insert; - die $error if $error; + + $cust_pay_batch->paybatchnum($old_cust_pay_batch->paybatchnum) + if $old_cust_pay_batch; + my $error; + if ($old_cust_pay_batch) { + $error = $cust_pay_batch->replace($old_cust_pay_batch) + } else { + $error = $cust_pay_batch->insert; + } + + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + die $error; + } + + my $unapplied = $cust_main->total_credited + $cust_main->total_unapplied_payments + $cust_main->in_transit_payments; + foreach my $cust_bill ($cust_main->open_cust_bill) { + #$dbh->commit or die $dbh->errstr if $oldAutoCommit; + my $cust_bill_pay_batch = new FS::cust_bill_pay_batch { + 'invnum' => $cust_bill->invnum, + 'paybatchnum' => $cust_pay_batch->paybatchnum, + 'amount' => $cust_bill->owed, + '_date' => time, + }; + if ($unapplied >= $cust_bill_pay_batch->amount){ + $unapplied -= $cust_bill_pay_batch->amount; + next; + }else{ + $cust_bill_pay_batch->amount(sprintf ( "%.2f", + $cust_bill_pay_batch->amount - $unapplied )); + $unapplied = 0; + } + $error = $cust_bill_pay_batch->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + die $error; + } + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; ''; } @@ -1496,12 +1747,14 @@ sub print_text { #setup template variables package FS::cust_bill::_template; #! - use vars qw( $invnum $date $page $total_pages @address $overdue @buf $agent ); + use vars qw( $custnum $invnum $date $agent @address $overdue + $page $total_pages @buf ); + $custnum = $self->custnum; $invnum = $self->invnum; $date = $self->_date; - $page = 1; $agent = $self->cust_main->agent->agent; + $page = 1; if ( $FS::cust_bill::invoice_lines ) { $total_pages = @@ -1634,6 +1887,7 @@ sub print_latex { } my %invoice_data = ( + 'custnum' => $self->custnum, 'invnum' => $self->invnum, 'date' => time2str('%b %o, %Y', $self->_date), 'today' => time2str('%b %o, %Y', $today), @@ -2034,6 +2288,7 @@ sub print_html { or die 'While compiling ' . $templatefile . ': ' . $Text::Template::ERROR; my %invoice_data = ( + 'custnum' => $self->custnum, 'invnum' => $self->invnum, 'date' => time2str('%b %o, %Y', $self->_date), 'today' => time2str('%b %o, %Y', $today), @@ -2095,6 +2350,7 @@ sub print_html { s/\\item / <li>/; s/\\end\{enumerate\}/<\/ol>/; s/\\textbf\{(.*)\}/<b>$1<\/b>/; + s/\\\\\*/ /; $_; } $conf->config_orbase('invoice_latexnotes', $template) @@ -2444,6 +2700,7 @@ use Data::Dumper; use MIME::Base64; sub process_re_X { my( $method, $job ) = ( shift, shift ); + warn "process_re_X $method for job $job\n" if $DEBUG; my $param = thaw(decode_base64(shift)); warn Dumper($param) if $DEBUG; @@ -2459,6 +2716,10 @@ sub process_re_X { sub re_X { my($method, $job, %param ) = @_; # [ 'begin', 'end', 'agentnum', 'open', 'days', 'newest_percust' ], + if ( $DEBUG ) { + warn "re_X $method for job $job with param:\n". + join( '', map { " $_ => ". $param{$_}. "\n" } keys %param ); + } #some false laziness w/search/cust_bill.html my $distinct = ''; diff --git a/FS/FS/cust_bill_ApplicationCommon.pm b/FS/FS/cust_bill_ApplicationCommon.pm new file mode 100644 index 000000000..9f61f5be5 --- /dev/null +++ b/FS/FS/cust_bill_ApplicationCommon.pm @@ -0,0 +1,390 @@ +package FS::cust_bill_ApplicationCommon; + +use strict; +use vars qw( @ISA $DEBUG $me ); +use List::Util qw(min); +use FS::Schema qw( dbdef ); +use FS::Record qw( qsearch qsearchs dbh ); + +@ISA = qw( FS::Record ); + +$DEBUG = 1; +$me = '[FS::cust_bill_ApplicationCommon]'; + +=head1 NAME + +FS::cust_bill_ApplicationCommon - Base class for bill application classes + +=head1 SYNOPSIS + +use FS::cust_bill_ApplicationCommon; + +@ISA = qw( FS::cust_bill_ApplicationCommon ); + +sub _app_source_name { 'payment'; } +sub _app_source_table { 'cust_pay'; } +sub _app_lineitem_breakdown_table { 'cust_bill_pay_pkg'; } + +=head1 DESCRIPTION + +FS::cust_bill_ApplicationCommon is intended as a base class for classes which +represent application of things to invoices, currently payments +(see L<FS::cust_bill_pay>) or credits (see L<FS::cust_credit_bill>). + +=head1 METHODS + +=item insert + +=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(@_) + || $self->apply_to_lineitems; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; + +} + +=item delete + +=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; + + foreach my $app ( $self->lineitem_applications ) { + my $error = $app->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 apply_to_lineitems + +Auto-applies this invoice application to specific line items, if possible. + +=cut + +sub apply_to_lineitems { + my $self = shift; + + my @apply = (); + + 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 @open = $self->cust_bill->open_cust_bill_pkg; #FOR UPDATE...? + warn "$me ". scalar(@open). " open line items for invoice ". + $self->cust_bill->invnum. ": ". join(', ', @open). "\n" + if $DEBUG; + my $total = 0; + $total += $_->setup + $_->recur foreach @open; + $total = sprintf('%.2f', $total); + + if ( $self->amount > $total ) { + $dbh->rollback if $oldAutoCommit; + return "Can't apply a ". $self->_app_source_name. ' of $'. $self->amount. + " greater than the remaining owed on line items (\$$total)"; + } + + #easy cases: + # - one lineitem (a simple special case of:) + # - amount is for whole invoice (well, all of remaining lineitem links) + if ( $self->amount == $total ) { + + warn "$me application amount covers remaining balance of invoice in full;". + "applying to those lineitems\n" + if $DEBUG; + + #@apply = map { [ $_, $_->amount ]; } @open; + @apply = map { [ $_, $_->setup || $_->recur ]; } @open; + + } else { + + #slightly magic case: + # - amount exactly and uniquely matches a single open lineitem + # (you must be trying to pay or credit that item, then) + + my @same = grep { $_->setup == $self->amount + || $_->recur == $self->amount + } + @open; + if ( scalar(@same) == 1 ) { + warn "$me application amount exactly and uniquely matches one lineitem;". + " applying to that lineitem\n" + if $DEBUG; + @apply = map { [ $_, $self->amount ]; } @same + } + + } + + unless ( @apply ) { + + warn "$me applying amount based on package weights\n" + if $DEBUG; + + #and the rest: + # - apply based on weights... + + my $weight_col = $self->_app_part_pkg_weight_column; + my @openweight = map { + my $open = $_; + my $cust_pkg = $open->cust_pkg; + my $weight = + $cust_pkg + ? ( $cust_pkg->part_pkg->$weight_col() || 0 ) + : 0; #default or per-tax weight? + [ $open, $weight ] + } + @open; + + my %saw = (); + my @weights = sort { $b <=> $a } # highest weight first + grep { ! $saw{$_}++ } # want a list of unique weights + map { $_->[1] } + @openweight; + + my $remaining_amount = $self->amount; + foreach my $weight ( @weights ) { + + #i hate it when my schwartz gets tangled + my @items = map { $_->[0] } grep { $weight == $_->[1] } @openweight; + + my $itemtotal = 0; + foreach my $item (@items) { $itemtotal += $item->setup || $item->recur; } + my $applytotal = min( $itemtotal, $remaining_amount ); + $remaining_amount -= $applytotal; + + warn "$me applying $applytotal ($remaining_amount remaining)". + " to ". scalar(@items). " lineitems with weight $weight\n" + if $DEBUG; + + #if some items are less than applytotal/num_items, then apply then in full + my $lessflag; + do { + $lessflag = 0; + + #no, not sprintf("%.2f", + # we want this rounded DOWN for purposes of checking for line items + # less than it, we don't want .66666 becoming .67 and causing this + # to trigger when it shouldn't + my $applyeach = int( 100 * $applytotal / scalar(@items) ) / 100; + + my @newitems = (); + foreach my $item ( @items ) { + my $itemamount = $item->setup || $item->recur; + if ( $itemamount < $applyeach ) { + warn "$me applying full $itemamount". + " to small line item (cust_bill_pkg ". $item->billpkgnum. ")\n" + if $DEBUG; + push @apply, [ $item, $itemamount ]; + $applytotal -= $itemamount; + $lessflag=1; + } else { + push @newitems, $item; + } + } + @items = @newitems; + + } while ( $lessflag ); + + #and now that we've fallen out of the loop, distribute the rest equally... + + # should cust_bill_pay_pkg and cust_credit_bill_pkg amount columns + # become real instead of numeric(10,2) ??? no.. + my $applyeach = sprintf("%.2f", $applytotal / scalar(@items) ); + + my @equi_apply = map { [ $_, $applyeach ] } @items; + + # or should we futz with pennies instead? yes, bah! + my $diff = + sprintf('%.0f', 100 * ( $applytotal - $applyeach * scalar(@items) ) ); + $diff = 0 if $diff eq '-0'; #yay ieee fp + if ( abs($diff) > scalar(@items) ) { + #we must have done something really wrong, the difference is more than + #a penny an item + $dbh->rollback if $oldAutoCommit; + return 'Error distributing pennies applying '. $self->_app_source_name. + " - can't distribute difference of $diff pennies". + ' among '. scalar(@items). ' line items'; + } + + warn "$me futzing with $diff pennies difference\n" + if $DEBUG && $diff; + + my $futz = 0; + while ( $diff != 0 && $futz < scalar(@equi_apply) ) { + if ( $diff > 0 ) { + $equi_apply[$futz++]->[1] += .01; + $diff -= 1; + } elsif ( $diff < 0 ) { + $equi_apply[$futz++]->[1] -= .01; + $diff += 1; + } else { + die "guru exception #5 (in fortran tongue the answer)"; + } + } + + if ( sprintf('%.0f', $diff ) ) { + $dbh->rollback if $oldAutoCommit; + return "couldn't futz with pennies enough: still $diff left"; + } + + if ( $DEBUG ) { + warn "$me applying ". $_->[1]. + " to line item (cust_bill_pkg ". $_->[0]->billpkgnum. ")\n" + foreach @equi_apply; + } + + + push @apply, @equi_apply; + + #$remaining_amount -= $applytotal; + last unless $remaining_amount; + + } + + } + + # do the applicaiton(s) + my $table = $self->lineitem_breakdown_table; + my $source_key = dbdef->table($self->table)->primary_key; + my $applied = 0; + foreach my $apply ( @apply ) { + my ( $cust_bill_pkg, $amount ) = @$apply; + $applied += $amount; + my $application = "FS::$table"->new( { + $source_key => $self->$source_key(), + 'billpkgnum' => $cust_bill_pkg->billpkgnum, + 'amount' => sprintf('%.2f', $amount), + 'setuprecur' => ( $cust_bill_pkg->setup > 0 ? 'setup' : 'recur' ), + 'sdate' => $cust_bill_pkg->sdate, + 'edate' => $cust_bill_pkg->edate, + }); + my $error = $application->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + #everything should always be applied to line items in full now... sanity check + $applied = sprintf('%.2f', $applied); + unless ( $applied == $self->amount ) { + $dbh->rollback if $oldAutoCommit; + return 'Error applying '. $self->_app_source_name. ' of $'. $self->amount. + ' to line items - only $'. $applied. ' was applied.'; + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; + +} + +=item lineitem_applications + +Returns all the specific line item applications for this invoice application. + +=cut + +sub lineitem_applications { + my $self = shift; + my $primary_key = dbdef->table($self->table)->primary_key; + qsearch({ + 'table' => $self->lineitem_breakdown_table, + 'hashref' => { $primary_key => $self->$primary_key() }, + }); + +} + +=item cust_bill + +Returns the invoice (see L<FS::cust_bill>) + +=cut + +sub cust_bill { + my $self = shift; + qsearchs( 'cust_bill', { 'invnum' => $self->invnum } ); +} + +=item lineitem_breakdown_table + +=cut + +sub lineitem_breakdown_table { + my $self = shift; + $self->_load_table($self->_app_lineitem_breakdown_table); +} + +sub _load_table { + my( $self, $table ) = @_; + eval "use FS::$table"; + die $@ if $@; + $table; +} + +=back + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::cust_bill_pay> and L<FS::cust_bill_pay_pkg>, +L<FS::cust_credit_bill> and L<FS::cust_credit_bill_pkg> + +=cut + +1; + diff --git a/FS/FS/cust_bill_event.pm b/FS/FS/cust_bill_event.pm index 128e5a53d..4496bed65 100644 --- a/FS/FS/cust_bill_event.pm +++ b/FS/FS/cust_bill_event.pm @@ -126,12 +126,13 @@ sub check { || $self->ut_textn('statustext') ; + return "Unknown eventpart ". $self->eventpart + unless my $part_bill_event = + qsearchs( 'part_bill_event' ,{ 'eventpart' => $self->eventpart } ); + return "Unknown invnum ". $self->invnum unless qsearchs( 'cust_bill' ,{ 'invnum' => $self->invnum } ); - return "Unknown eventpart ". $self->eventpart - unless qsearchs( 'part_bill_event' ,{ 'eventpart' => $self->eventpart } ); - $self->SUPER::check; } @@ -173,6 +174,21 @@ sub retry { $self->replace($old); } +=item retryable + +Changes the statustext of this event to B<retriable>, rendering it +retriable (should retry be called). + +=cut + +sub retriable { + my $self = shift; + return '' unless $self->status eq 'done'; + my $old = ref($self)->new( { $self->hash } ); + $self->statustext('retriable'); + $self->replace($old); +} + =back =head1 SUBROUTINES diff --git a/FS/FS/cust_bill_pay.pm b/FS/FS/cust_bill_pay.pm index 7abbe9a3b..74a8bcdd4 100644 --- a/FS/FS/cust_bill_pay.pm +++ b/FS/FS/cust_bill_pay.pm @@ -2,11 +2,12 @@ package FS::cust_bill_pay; use strict; use vars qw( @ISA $conf ); -use FS::Record qw( qsearch qsearchs dbh ); +use FS::Record qw( qsearchs ); +use FS::cust_bill_ApplicationCommon; use FS::cust_bill; use FS::cust_pay; -@ISA = qw( FS::Record ); +@ISA = qw( FS::cust_bill_ApplicationCommon ); #ask FS::UID to run this stuff for us later FS::UID->install_callback( sub { @@ -35,8 +36,9 @@ FS::cust_bill_pay - Object methods for cust_bill_pay records =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: +specific invoice. FS::cust_bill_pay inherits from +FS::cust_bill_ApplicationCommon and FS::Record. The following fields are +currently supported: =over 4 @@ -65,6 +67,11 @@ Creates a new record. To add the record to the database, see L<"insert">. sub table { 'cust_bill_pay'; } +sub _app_source_name { 'payment'; } +sub _app_source_table { 'cust_pay'; } +sub _app_lineitem_breakdown_table { 'cust_bill_pay_pkg'; } +sub _app_part_pkg_weight_column { 'pay_weight'; } + =item insert Adds this record to the database. If there is an error, returns the error, @@ -81,6 +88,8 @@ sub delete { my $self = shift; return "Can't delete application for closed payment" if $self->cust_pay->closed =~ /^Y/i; + return "Can't delete application for closed invoice" + if $self->cust_bill->closed =~ /^Y/i; $self->SUPER::delete(@_); } @@ -91,13 +100,14 @@ Currently unimplemented (accounting reasons). =cut sub replace { - return "Can't (yet?) modify cust_bill_pay records!"; + return "Can't modify application of payment!"; } =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. +Checks all fields to make sure this is a valid payment application. If there +is an error, returns the error, otherwise returns false. Called by the insert +method. =cut @@ -106,30 +116,22 @@ sub check { my $error = $self->ut_numbern('billpaynum') - || $self->ut_number('invnum') - || $self->ut_number('paynum') - || $self->ut_money('amount') + || $self->ut_foreign_key('paynum', 'cust_pay', 'paynum' ) + || $self->ut_foreign_key('invnum', 'cust_bill', 'invnum' ) || $self->ut_numbern('_date') + || $self->ut_money('amount') ; return $error if $error; return "amount must be > 0" if $self->amount <= 0; - return "Unknown invoice" - unless my $cust_bill = - qsearchs( 'cust_bill', { 'invnum' => $self->invnum } ); - - return "Unknown payment" - unless my $cust_pay = - qsearchs( 'cust_pay', { 'paynum' => $self->paynum } ); - $self->_date(time) unless $self->_date; return "Cannot apply more than remaining value of invoice" - unless $self->amount <= $cust_bill->owed; + unless $self->amount <= $self->cust_bill->owed; return "Cannot apply more than remaining value of payment" - unless $self->amount <= $cust_pay->unapplied; + unless $self->amount <= $self->cust_pay->unapplied; $self->SUPER::check; } @@ -145,26 +147,12 @@ sub cust_pay { 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 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 diff --git a/FS/FS/cust_bill_pay_batch.pm b/FS/FS/cust_bill_pay_batch.pm new file mode 100644 index 000000000..30fb74432 --- /dev/null +++ b/FS/FS/cust_bill_pay_batch.pm @@ -0,0 +1,120 @@ +package FS::cust_bill_pay_batch; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::cust_bill_pay_batch - Object methods for cust_bill_pay_batch records + +=head1 SYNOPSIS + + use FS::cust_bill_pay_batch; + + $record = new FS::cust_bill_pay_batch \%hash; + $record = new FS::cust_bill_pay_batch { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::cust_bill_pay_batch object represents a relationship between a +customer's bill and a batch. FS::cust_bill_pay_batch inherits from +FS::Record. The following fields are currently supported: + +=over 4 + +=item billpaynum - primary key + +=item invnum - customer's bill (invoice) + +=item paybatchnum - entry in cust_pay_batch table + +=item amount - + +=item _date - + + +=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_bill_pay_batch'; } + +=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 + +sub check { + my $self = shift; + + my $error = + $self->ut_numbern('billpaynum') + || $self->ut_number('invnum') + || $self->ut_number('paybatchnum') + || $self->ut_money('amount') + || $self->ut_numbern('_date') + ; + return $error if $error; + + $self->SUPER::check; +} + +=back + +=head1 BUGS + +Just hangs there. + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/cust_bill_pay_pkg.pm b/FS/FS/cust_bill_pay_pkg.pm new file mode 100644 index 000000000..cdbace960 --- /dev/null +++ b/FS/FS/cust_bill_pay_pkg.pm @@ -0,0 +1,141 @@ +package FS::cust_bill_pay_pkg; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::cust_bill_pay_pkg - Object methods for cust_bill_pay_pkg records + +=head1 SYNOPSIS + + use FS::cust_bill_pay_pkg; + + $record = new FS::cust_bill_pay_pkg \%hash; + $record = new FS::cust_bill_pay_pkg { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::cust_bill_pay_pkg object represents application of a payment (see +L<FS::cust_bill_pay>) to a specific line item within an invoice (see +L<FS::cust_bill_pkg>). FS::cust_bill_pay_pkg inherits from FS::Record. The +following fields are currently supported: + +=over 4 + +=item billpaypkgnum - primary key + +=item billpaynum - Payment application to the overall invoice (see L<FS::cust_bill_pay>) + +=item billpkgnum - Line item to which payment is applied (see L<FS::cust_bill_pkg>) + +=item amount - Amount of the payment applied to this line item. + +=item setuprecur - 'setup' or 'recur', designates whether the payment was applied to the setup or recurring portion of the line item. + +=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 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 + +# the new method can be inherited from FS::Record, if a table method is defined + +sub table { 'cust_bill_pay_pkg'; } + +=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 payment application. 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('billpaypkgnum') + || $self->ut_foreign_key('billpaynum', 'cust_bill_pay', 'billpaynum' ) + || $self->ut_foreign_key('billpkgnum', 'cust_bill_pkg', 'billpkgnum' ) + || $self->ut_money('amount') + || $self->ut_enum('setuprecur', [ 'setup', 'recur' ] ) + || $self->ut_numbern('sdate') + || $self->ut_numbern('edate') + ; + return $error if $error; + + $self->SUPER::check; +} + +=back + +=head1 BUGS + +B<setuprecur> field is a kludge to compensate for cust_bill_pkg having separate +setup and recur fields. It should be removed once that's fixed. + +=head1 SEE ALSO + +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 index d718b05fd..9fddf6bf5 100644 --- a/FS/FS/cust_bill_pkg.pm +++ b/FS/FS/cust_bill_pkg.pm @@ -7,6 +7,8 @@ use FS::cust_main_Mixin; use FS::cust_pkg; use FS::cust_bill; use FS::cust_bill_pkg_detail; +use FS::cust_bill_pay_pkg; +use FS::cust_credit_bill_pkg; @ISA = qw( FS::cust_main_Mixin FS::Record ); @@ -190,6 +192,17 @@ sub cust_pkg { qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } ); } +=item cust_bill + +Returns the invoice (see L<FS::cust_bill>) for this invoice line item. + +=cut + +sub cust_bill { + my $self = shift; + qsearchs( 'cust_bill', { 'invnum' => $self->invnum } ); +} + =item details Returns an array of detail information for the invoice line item. @@ -224,18 +237,78 @@ sub desc { } } -=back +=item owed_setup -=head1 CLASS METHODS +Returns the amount owed (still outstanding) on this line item's setup fee, +which is the amount of the line item minus all payment applications (see +L<FS::cust_bill_pay_pkg> and credit applications (see +L<FS::cust_credit_bill_pkg>). -=over 4 +=cut + +sub owed_setup { + my $self = shift; + $self->owed('setup', @_); +} + +=item owed_recur -=item +Returns the amount owed (still outstanding) on this line item's recurring fee, +which is the amount of the line item minus all payment applications (see +L<FS::cust_bill_pay_pkg> and credit applications (see +L<FS::cust_credit_bill_pkg>). + +=cut + +sub owed_recur { + my $self = shift; + $self->owed('recur', @_); +} + +# modeled after cust_bill::owed... +sub owed { + my( $self, $field ) = @_; + my $balance = $self->$field(); + $balance -= $_->amount foreach ( $self->cust_bill_pay_pkg($field) ); + $balance -= $_->amount foreach ( $self->cust_credit_bill_pkg($field) ); + $balance = sprintf( '%.2f', $balance ); + $balance =~ s/^\-0\.00$/0.00/; #yay ieee fp + $balance; +} + +sub cust_bill_pay_pkg { + my( $self, $field ) = @_; + qsearch( 'cust_bill_pay_pkg', { 'billpkgnum' => $self->billpkgnum, + 'setuprecur' => $field, + } + ); +} + +sub cust_credit_bill_pkg { + my( $self, $field ) = @_; + qsearch( 'cust_credit_bill_pkg', { 'billpkgnum' => $self->billpkgnum, + 'setuprecur' => $field, + } + ); +} =back =head1 BUGS +setup and recur shouldn't be separate fields. There should be one "amount" +field and a flag to tell you if it is a setup/one-time fee or a recurring fee. + +A line item with both should really be two separate records (preserving +sdate and edate for setup fees for recurring packages - that information may +be valuable later). Invoice generation (cust_main::bill), invoice printing +(cust_bill), tax reports (report_tax.cgi) and line item reports +(cust_bill_pkg.cgi) would need to be updated. + +owed_setup and owed_recur could then be repaced by just owed, and +cust_bill::open_cust_bill_pkg and +cust_bill_ApplicationCommon::apply_to_lineitems could be simplified. + =head1 SEE ALSO L<FS::Record>, L<FS::cust_bill>, L<FS::cust_pkg>, L<FS::cust_main>, schema.html diff --git a/FS/FS/cust_credit.pm b/FS/FS/cust_credit.pm index 9cc92d2e8..7ffb1d178 100644 --- a/FS/FS/cust_credit.pm +++ b/FS/FS/cust_credit.pm @@ -134,10 +134,13 @@ sub insert { =item delete -Currently unimplemented. +Unless the closed flag is set, deletes this credit and all associated +applications (see L<FS::cust_credit_bill>). In most cases, you want to use +the void method instead to leave a record of the deleted credit. =cut +# very similar to FS::cust_pay::delete sub delete { my $self = shift; return "Can't delete closed credit" if $self->closed =~ /^Y/i; @@ -169,7 +172,7 @@ sub delete { if ( $conf->config('deletecredits') ne '' ) { - my $cust_main = qsearchs('cust_main',{ 'custnum' => $self->custnum }); + my $cust_main = $self->cust_main; my $error = send_email( 'from' => $conf->config('invoice_from'), #??? well as good as any @@ -203,8 +206,7 @@ sub delete { =item replace OLD_RECORD -Credits may not be modified; there would then be no record the credit was ever -posted. +You can, but probably shouldn't modify credits... =cut diff --git a/FS/FS/cust_credit_bill.pm b/FS/FS/cust_credit_bill.pm index 695df6e8d..411bae21a 100644 --- a/FS/FS/cust_credit_bill.pm +++ b/FS/FS/cust_credit_bill.pm @@ -4,12 +4,11 @@ use strict; use vars qw( @ISA $conf ); 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_ApplicationCommon; use FS::cust_bill; +use FS::cust_credit; -@ISA = qw( FS::Record ); +@ISA = qw( FS::cust_bill_ApplicationCommon ); #ask FS::UID to run this stuff for us later FS::UID->install_callback( sub { @@ -39,7 +38,8 @@ FS::cust_credit_bill - Object methods for cust_credit_bill records 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_bill -inherits from FS::Record. The following fields are currently supported: +inherits from FS::cust_bill_ApplicationCommon and FS::Record. The following +fields are currently supported: =over 4 @@ -69,6 +69,11 @@ see L<"insert">. sub table { 'cust_credit_bill'; } +sub _app_source_name { 'credit'; } +sub _app_source_table { 'cust_credit'; } +sub _app_lineitem_breakdown_table { 'cust_credit_bill_pkg'; } +sub _app_part_pkg_weight_column { 'credit_weight'; } + =item insert Adds this cust_credit_bill to the database ("Posts" all or part of a credit). @@ -84,6 +89,8 @@ sub delete { my $self = shift; return "Can't delete application for closed credit" if $self->cust_credit->closed =~ /^Y/i; + return "Can't delete application for closed invoice" + if $self->cust_bill->closed =~ /^Y/i; $self->SUPER::delete(@_); } @@ -110,8 +117,8 @@ sub check { my $error = $self->ut_numbern('creditbillnum') - || $self->ut_number('crednum') - || $self->ut_number('invnum') + || $self->ut_foreign_key('crednum', 'cust_credit', 'crednum') + || $self->ut_foreign_key('invnum', 'cust_bill', 'invnum' ) || $self->ut_numbern('_date') || $self->ut_money('amount') ; @@ -119,21 +126,13 @@ sub check { 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; + unless $self->amount <= $self->cust_credit->credited; return "Cannot apply more than remaining value of invoice" - unless $self->amount <= $cust_bill->owed; + unless $self->amount <= $self->cust_bill->owed; $self->SUPER::check; } @@ -149,26 +148,17 @@ sub cust_credit { qsearchs( 'cust_credit', { 'crednum' => $self->crednum } ); } -=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 BUGS The delete method. +This probably should have been called cust_bill_credit. + =head1 SEE ALSO -L<FS::Record>, L<FS::cust_refund>, L<FS::cust_bill>, L<FS::cust_credit>, +L<FS::Record>, L<FS::cust_bill>, L<FS::cust_credit>, schema.html from the base documentation. =cut diff --git a/FS/FS/cust_credit_bill_pkg.pm b/FS/FS/cust_credit_bill_pkg.pm new file mode 100644 index 000000000..7252be537 --- /dev/null +++ b/FS/FS/cust_credit_bill_pkg.pm @@ -0,0 +1,141 @@ +package FS::cust_credit_bill_pkg; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::cust_credit_bill_pkg - Object methods for cust_credit_bill_pkg records + +=head1 SYNOPSIS + + use FS::cust_credit_bill_pkg; + + $record = new FS::cust_credit_bill_pkg \%hash; + $record = new FS::cust_credit_bill_pkg { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::cust_credit_bill_pkg object represents application of a credit (see +L<FS::cust_credit_bill>) to a specific line item within an invoice +(see L<FS::cust_bill_pkg>). FS::cust_credit_bill_pkg inherits from FS::Record. +The following fields are currently supported: + +=over 4 + +=item creditbillpkg - primary key + +=item creditbillnum - Credit application to the overall invoice (see L<FS::cust_credit::bill>) + +=item billpkgnum - Line item to which credit is applied (see L<FS::cust_bill_pkg>) + +=item amount - Amount of the credit applied to this line item. + +=item setuprecur - 'setup' or 'recur', designates whether the payment was applied to the setup or recurring portion of the line item. + +=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 example. To add the example to the database, see L<"insert">. + +Note that this stores the hash reference, not a distinct copy of the hash it +points to. You can ask the object for a copy with the I<hash> method. + +=cut + +# the new method can be inherited from FS::Record, if a table method is defined + +sub table { 'cust_credit_bill_pkg'; } + +=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 credit applicaiton. 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('creditbillpkgnum') + || $self->ut_foreign_key('creditbillnum', 'cust_credit_bill', 'creditbillnum') + || $self->ut_foreign_key('billpkgnum', 'cust_bill_pkg', 'billpkgnum' ) + || $self->ut_money('amount') + || $self->ut_enum('setuprecur', [ 'setup', 'recur' ] ) + || $self->ut_numbern('sdate') + || $self->ut_numbern('edate') + ; + return $error if $error; + + $self->SUPER::check; +} + +=back + +=head1 BUGS + +B<setuprecur> field is a kludge to compensate for cust_bill_pkg having separate +setup and recur fields. It should be removed once that's fixed. + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/cust_credit_refund.pm b/FS/FS/cust_credit_refund.pm index 36c77aa59..f237efed2 100644 --- a/FS/FS/cust_credit_refund.pm +++ b/FS/FS/cust_credit_refund.pm @@ -70,20 +70,27 @@ otherwise returns false. sub insert { my $self = shift; - my $error = $self->SUPER::insert; - return $error if $error; - - ''; + return "Can't apply refund to closed credit" + if $self->cust_credit->closed =~ /^Y/i; + return "Can't apply credit to closed refund" + if $self->cust_refund->closed =~ /^Y/i; + $self->SUPER::insert(@_); } =item delete -Currently unimplemented (accounting reasons). +Remove this cust_credit_refund from the database. If there is an error, +returns the error, otherwise returns false. =cut sub delete { - return "Can't (yet?) delete cust_credit_refund records!"; + my $self = shift; + return "Can't remove refund from closed credit" + if $self->cust_credit->closed =~ /^Y/i; + return "Can't remove credit from closed refund" + if $self->cust_refund->closed =~ /^Y/i; + $self->SUPER::delete(@_); } =item replace OLD_RECORD diff --git a/FS/FS/cust_main.pm b/FS/FS/cust_main.pm index a265e4177..08b8c3749 100644 --- a/FS/FS/cust_main.pm +++ b/FS/FS/cust_main.pm @@ -16,9 +16,11 @@ BEGIN { } use Digest::MD5 qw(md5_base64); use Date::Format; +use Date::Parse; #use Date::Manip; use String::Approx qw(amatch); use Business::CreditCard 0.28; +use Locale::Country; use FS::UID qw( getotaker dbh ); use FS::Record qw( qsearchs qsearch dbdef ); use FS::Misc qw( send_email ); @@ -40,15 +42,17 @@ use FS::cust_bill_pay; use FS::prepay_credit; use FS::queue; use FS::part_pkg; -use FS::part_bill_event; +use FS::part_bill_event qw(due_events); use FS::cust_bill_event; use FS::cust_tax_exempt; +use FS::cust_tax_exempt_pkg; use FS::type_pkgs; use FS::payment_gateway; use FS::agent_payment_gateway; use FS::banned_pay; +use FS::payinfo_Mixin; -@ISA = qw( FS::Record ); +@ISA = qw( FS::Record FS::payinfo_Mixin ); @EXPORT_OK = qw( smart_search ); @@ -77,7 +81,7 @@ sub _cache { my $self = shift; my ( $hashref, $cache ) = @_; if ( exists $hashref->{'pkgnum'} ) { -# #@{ $self->{'_pkgnum'} } = (); + #@{ $self->{'_pkgnum'} } = (); my $subcache = $cache->subcache( 'pkgnum', 'cust_pkg', $hashref->{custnum}); $self->{'_pkgnum'} = $subcache; #push @{ $self->{'_pkgnum'} }, @@ -117,8 +121,6 @@ FS::cust_main - Object methods for cust_main records $error = $record->collect; $error = $record->collect %options; $error = $record->collect 'invoice_time' => $time, - 'batch_card' => 'yes', - 'report_badcard' => 'yes', ; =head1 DESCRIPTION @@ -188,81 +190,15 @@ FS::Record. The following fields are currently supported: =item ship_fax - phone (optional) -=item payby +=item payby - Payment Type (See L<FS::payinfo_Mixin> for valid payby values) -I<CARD> (credit card - automatic), I<DCRD> (credit card - on-demand), I<CHEK> (electronic check - automatic), I<DCHK> (electronic check - on-demand), I<LECB> (Phone bill billing), I<BILL> (billing), I<COMP> (free), or I<PREPAY> (special billing type: applies a credit - see L<FS::prepay_credit> and sets billing type to I<BILL>) - -=item payinfo - -Card Number, P.O., comp issuer (4-8 lowercase alphanumerics; think username) or prepayment identifier (see L<FS::prepay_credit>) - -=cut - -sub payinfo { - my($self,$payinfo) = @_; - if ( defined($payinfo) ) { - $self->paymask($payinfo); - $self->setfield('payinfo', $payinfo); # This is okay since we are the 'setter' - } else { - $payinfo = $self->getfield('payinfo'); # This is okay since we are the 'getter' - return $payinfo; - } -} +=item payinfo - Payment Information (See L<FS::payinfo_Mixin> for data format) +=item paymask - Masked payinfo (See L<FS::payinfo_Mixin> for how this works) =item paycvv - -Card Verification Value, "CVV2" (also known as CVC2 or CID), the 3 or 4 digit number on the back (or front, for American Express) of the credit card - -=cut - -=item paymask - Masked payment type - -=over 4 - -=item Credit Cards - -Mask all but the last four characters. - -=item Checks -Mask all but last 2 of account number and bank routing number. - -=item Others - -Do nothing, return the unmasked string. - -=back - -=cut - -sub paymask { - my($self,$value)=@_; - - # If it doesn't exist then generate it - my $paymask=$self->getfield('paymask'); - if (!defined($value) && (!defined($paymask) || $paymask eq '')) { - $value = $self->payinfo; - } - - if ( defined($value) && !$self->is_encrypted($value)) { - my $payinfo = $value; - my $payby = $self->payby; - if ($payby eq 'CARD' || $payby eq 'DCRD') { # Credit Cards (Show last four) - $paymask = 'x'x(length($payinfo)-4). substr($payinfo,(length($payinfo)-4)); - } elsif ($payby eq 'CHEK' || - $payby eq 'DCHK' ) { # Checks (Show last 2 @ bank) - my( $account, $aba ) = split('@', $payinfo ); - $paymask = 'x'x(length($account)-2). substr($account,(length($account)-2))."@".$aba; - } else { # Tie up loose ends - $paymask = $payinfo; - } - $self->setfield('paymask', $paymask); # This is okay since we are the 'setter' - } elsif (defined($value) && $self->is_encrypted($value)) { - $paymask = 'N/A'; - } - return $paymask; -} +Card Verification Value, "CVV2" (also known as CVC2 or CID), the 3 or 4 digit number on the back (or front, for American Express) of the credit card =item paydate - expiration date, mm/yyyy, m/yyyy, mm/yy or m/yy @@ -284,6 +220,8 @@ sub paymask { =item referral_custnum - referring customer number +=item spool_cdr - Enable individual CDR spooling, empty or `Y' + =back =head1 METHODS @@ -334,7 +272,7 @@ Currently available options are: I<depend_jobnum> and I<noexport>. If I<depend_jobnum> is set, all provisioning jobs will have a dependancy on the supplied jobnum (they will not run until the specific job completes). This can be used to defer provisioning until some action completes (such -as running the customer's credit card sucessfully). +as running the customer's credit card successfully). The I<noexport> option is deprecated. If I<noexport> is set true, no provisioning jobs (exports) are scheduled. (You can schedule them later with @@ -394,6 +332,8 @@ sub insert { warn " inserting $self\n" if $DEBUG > 1; + $self->signupdate(time) unless $self->signupdate; + my $error = $self->SUPER::insert; if ( $error ) { $dbh->rollback if $oldAutoCommit; @@ -413,6 +353,20 @@ sub insert { $self->invoicing_list( $invoicing_list ); } + if ( $conf->config('cust_main-skeleton_tables') + && $conf->config('cust_main-skeleton_custnum') ) { + + warn " inserting skeleton records\n" + if $DEBUG > 1; + + my $error = $self->start_copy_skel; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + } + warn " ordering packages\n" if $DEBUG > 1; @@ -455,6 +409,133 @@ sub insert { } +sub start_copy_skel { + my $self = shift; + + #'mg_user_preference' => {}, + #'mg_user_indicator_profile.user_indicator_profile_id' => { 'mg_profile_indicator.profile_indicator_id' => { 'mg_profile_details.profile_detail_id' }, }, + #'mg_watchlist_header.watchlist_header_id' => { 'mg_watchlist_details.watchlist_details_id' }, + #'mg_user_grid_header.grid_header_id' => { 'mg_user_grid_details.user_grid_details_id' }, + #'mg_portfolio_header.portfolio_header_id' => { 'mg_portfolio_trades.portfolio_trades_id' => { 'mg_portfolio_trades_positions.portfolio_trades_positions_id' } }, + my @tables = eval($conf->config_binary('cust_main-skeleton_tables')); + die $@ if $@; + + _copy_skel( 'cust_main', #tablename + $conf->config('cust_main-skeleton_custnum'), #sourceid + $self->custnum, #destid + @tables, #child tables + ); +} + +#recursive subroutine, not a method +sub _copy_skel { + my( $table, $sourceid, $destid, %child_tables ) = @_; + + my $primary_key; + if ( $table =~ /^(\w+)\.(\w+)$/ ) { + ( $table, $primary_key ) = ( $1, $2 ); + } else { + my $dbdef_table = dbdef->table($table); + $primary_key = $dbdef_table->primary_key + or return "$table has no primary key". + " (or do you need to run dbdef-create?)"; + } + + warn " _copy_skel: $table.$primary_key $sourceid to $destid for ". + join (', ', keys %child_tables). "\n" + if $DEBUG > 2; + + foreach my $child_table_def ( keys %child_tables ) { + + my $child_table; + my $child_pkey = ''; + if ( $child_table_def =~ /^(\w+)\.(\w+)$/ ) { + ( $child_table, $child_pkey ) = ( $1, $2 ); + } else { + $child_table = $child_table_def; + + $child_pkey = dbdef->table($child_table)->primary_key; + # or return "$table has no primary key". + # " (or do you need to run dbdef-create?)\n"; + } + + my $sequence = ''; + if ( keys %{ $child_tables{$child_table_def} } ) { + + return "$child_table has no primary key". + " (run dbdef-create or try specifying it?)\n" + unless $child_pkey; + + #false laziness w/Record::insert and only works on Pg + #refactor the proper last-inserted-id stuff out of Record::insert if this + # ever gets use for anything besides a quick kludge for one customer + my $default = dbdef->table($child_table)->column($child_pkey)->default; + $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i + or return "can't parse $child_table.$child_pkey default value ". + " for sequence name: $default"; + $sequence = $1; + + } + + my @sel_columns = grep { $_ ne $primary_key } + dbdef->table($child_table)->columns; + my $sel_columns = join(', ', @sel_columns ); + + my @ins_columns = grep { $_ ne $child_pkey } @sel_columns; + my $ins_columns = ' ( '. join(', ', $primary_key, @ins_columns ). ' ) '; + my $placeholders = ' ( ?, '. join(', ', map '?', @ins_columns ). ' ) '; + + my $sel_st = "SELECT $sel_columns FROM $child_table". + " WHERE $primary_key = $sourceid"; + warn " $sel_st\n" + if $DEBUG > 2; + my $sel_sth = dbh->prepare( $sel_st ) + or return dbh->errstr; + + $sel_sth->execute or return $sel_sth->errstr; + + while ( my $row = $sel_sth->fetchrow_hashref ) { + + warn " selected row: ". + join(', ', map { "$_=".$row->{$_} } keys %$row ). "\n" + if $DEBUG > 2; + + my $statement = + "INSERT INTO $child_table $ins_columns VALUES $placeholders"; + my $ins_sth =dbh->prepare($statement) + or return dbh->errstr; + my @param = ( $destid, map $row->{$_}, @ins_columns ); + warn " $statement: [ ". join(', ', @param). " ]\n" + if $DEBUG > 2; + $ins_sth->execute( @param ) + or return $ins_sth->errstr; + + #next unless keys %{ $child_tables{$child_table} }; + next unless $sequence; + + #another section of that laziness + my $seq_sql = "SELECT currval('$sequence')"; + my $seq_sth = dbh->prepare($seq_sql) or return dbh->errstr; + $seq_sth->execute or return $seq_sth->errstr; + my $insertid = $seq_sth->fetchrow_arrayref->[0]; + + # don't drink soap! recurse! recurse! okay! + my $error = + _copy_skel( $child_table_def, + $row->{$child_pkey}, #sourceid + $insertid, #destid + %{ $child_tables{$child_table_def} }, + ); + return $error if $error; + + } + + } + + return ''; + +} + =item order_pkgs HASHREF, [ SECONDSREF, [ , OPTION => VALUE ... ] ] Like the insert method on an existing record, this method orders a package @@ -478,7 +559,7 @@ Currently available options are: I<depend_jobnum> and I<noexport>. If I<depend_jobnum> is set, all provisioning jobs will have a dependancy on the supplied jobnum (they will not run until the specific job completes). This can be used to defer provisioning until some action completes (such -as running the customer's credit card sucessfully). +as running the customer's credit card successfully). The I<noexport> option is deprecated. If I<noexport> is set true, no provisioning jobs (exports) are scheduled. (You can schedule them later with @@ -546,21 +627,23 @@ sub order_pkgs { ''; #no error } -=item recharge_prepay IDENTIFIER | PREPAY_CREDIT_OBJ [ , AMOUNTREF, SECONDSREF ] +=item recharge_prepay IDENTIFIER | PREPAY_CREDIT_OBJ [ , AMOUNTREF, SECONDSREF, UPBYTEREF, DOWNBYTEREF ] Recharges this (existing) customer with the specified prepaid card (see L<FS::prepay_credit>), specified either by I<identifier> or as an FS::prepay_credit object. If there is an error, returns the error, otherwise returns false. -Optionally, two scalar references can be passed as well. They will have their -values filled in with the amount and number of seconds applied by this prepaid +Optionally, four scalar references can be passed as well. They will have their +values filled in with the amount, number of seconds, and number of upload and +download bytes applied by this prepaid card. =cut sub recharge_prepay { - my( $self, $prepay_credit, $amountref, $secondsref ) = @_; + my( $self, $prepay_credit, $amountref, $secondsref, + $upbytesref, $downbytesref, $totalbytesref ) = @_; local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; @@ -573,10 +656,14 @@ sub recharge_prepay { local $FS::UID::AutoCommit = 0; my $dbh = dbh; - my( $amount, $seconds ) = ( 0, 0 ); + my( $amount, $seconds, $upbytes, $downbytes, $totalbytes) = ( 0, 0, 0, 0, 0 ); - my $error = $self->get_prepay($prepay_credit, \$amount, \$seconds) + my $error = $self->get_prepay($prepay_credit, \$amount, + \$seconds, \$upbytes, \$downbytes, \$totalbytes) || $self->increment_seconds($seconds) + || $self->increment_upbytes($upbytes) + || $self->increment_downbytes($downbytes) + || $self->increment_totalbytes($totalbytes) || $self->insert_cust_pay_prepay( $amount, ref($prepay_credit) ? $prepay_credit->identifier @@ -590,6 +677,9 @@ sub recharge_prepay { if ( defined($amountref) ) { $$amountref = $amount; } if ( defined($secondsref) ) { $$secondsref = $seconds; } + if ( defined($upbytesref) ) { $$upbytesref = $upbytes; } + if ( defined($downbytesref) ) { $$downbytesref = $downbytes; } + if ( defined($totalbytesref) ) { $$totalbytesref = $totalbytes; } $dbh->commit or die $dbh->errstr if $oldAutoCommit; ''; @@ -613,7 +703,8 @@ If there is an error, returns the error, otherwise returns false. sub get_prepay { - my( $self, $prepay_credit, $amountref, $secondsref ) = @_; + my( $self, $prepay_credit, $amountref, $secondsref, + $upref, $downref, $totalref) = @_; local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; @@ -660,12 +751,51 @@ sub get_prepay { $$amountref += $prepay_credit->amount; $$secondsref += $prepay_credit->seconds; + $$upref += $prepay_credit->upbytes; + $$downref += $prepay_credit->downbytes; + $$totalref += $prepay_credit->totalbytes; $dbh->commit or die $dbh->errstr if $oldAutoCommit; ''; } +=item increment_upbytes SECONDS + +Updates this customer's single or primary account (see L<FS::svc_acct>) by +the specified number of upbytes. If there is an error, returns the error, +otherwise returns false. + +=cut + +sub increment_upbytes { + _increment_column( shift, 'upbytes', @_); +} + +=item increment_downbytes SECONDS + +Updates this customer's single or primary account (see L<FS::svc_acct>) by +the specified number of downbytes. If there is an error, returns the error, +otherwise returns false. + +=cut + +sub increment_downbytes { + _increment_column( shift, 'downbytes', @_); +} + +=item increment_totalbytes SECONDS + +Updates this customer's single or primary account (see L<FS::svc_acct>) by +the specified number of totalbytes. If there is an error, returns the error, +otherwise returns false. + +=cut + +sub increment_totalbytes { + _increment_column( shift, 'totalbytes', @_); +} + =item increment_seconds SECONDS Updates this customer's single or primary account (see L<FS::svc_acct>) by @@ -675,10 +805,24 @@ otherwise returns false. =cut sub increment_seconds { - my( $self, $seconds ) = @_; - warn "$me increment_seconds called: $seconds seconds\n" + _increment_column( shift, 'seconds', @_); +} + +=item _increment_column AMOUNT + +Updates this customer's single or primary account (see L<FS::svc_acct>) by +the specified number of seconds or bytes. If there is an error, returns +the error, otherwise returns false. + +=cut + +sub _increment_column { + my( $self, $column, $amount ) = @_; + warn "$me increment_column called: $column, $amount\n" if $DEBUG; + return '' unless $amount; + my @cust_pkg = grep { $_->part_pkg->svcpart('svc_acct') } $self->ncancelled_pkgs; @@ -708,7 +852,8 @@ sub increment_seconds { ' ('. $svc_acct->email. ")\n" if $DEBUG > 1; - $svc_acct->increment_seconds($seconds); + $column = "increment_$column"; + $svc_acct->$column($amount); } @@ -866,7 +1011,9 @@ sub delete { 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); + my $error = $new_cust_pkg->replace($cust_pkg, + options => { $cust_pkg->options }, + ); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; @@ -921,6 +1068,8 @@ sub replace { my $self = shift; my $old = shift; my @param = @_; + warn "$me replace called\n" + if $DEBUG; local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; @@ -929,26 +1078,24 @@ sub replace { local $SIG{TSTP} = 'IGNORE'; local $SIG{PIPE} = 'IGNORE'; - # If the mask is blank then try to set it - if we can... - if (!defined($self->getfield('paymask')) || $self->getfield('paymask') eq '') { - $self->paymask($self->payinfo); - } - # We absolutely have to have an old vs. new record to make this work. if (!defined($old)) { $old = qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); } - if ( $self->payby eq 'COMP' && $self->payby ne $old->payby - && $conf->config('users-allow_comp') ) { - return "You are not permitted to create complimentary accounts." - unless grep { $_ eq getotaker } $conf->config('users-allow_comp'); + my $curuser = $FS::CurrentUser::CurrentUser; + if ( $self->payby eq 'COMP' + && $self->payby ne $old->payby + && ! $curuser->access_right('Complimentary customer') + ) + { + return "You are not permitted to create complimentary accounts."; } local($ignore_expired_card) = 1 if $old->payby =~ /^(CARD|DCRD)$/ && $self->payby =~ /^(CARD|DCRD)$/ - && $old->payinfo eq $self->payinfo; + && ( $old->payinfo eq $self->payinfo || $old->paymask eq $self->paymask ); my $oldAutoCommit = $FS::UID::AutoCommit; local $FS::UID::AutoCommit = 0; @@ -1015,15 +1162,19 @@ sub queue_fuzzyfiles_update { my $dbh = dbh; my $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' }; - my $error = $queue->insert($self->getfield('last'), $self->company); + my $error = $queue->insert( map $self->getfield($_), + qw(first last 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 ) { + if ( $self->ship_last ) { $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' }; - $error = $queue->insert($self->getfield('ship_last'), $self->ship_company); + $error = $queue->insert( map $self->getfield("ship_$_"), + qw(first last company) + ); if ( $error ) { $dbh->rollback if $oldAutoCommit; return "queueing job (transaction rolled back): $error"; @@ -1052,9 +1203,12 @@ sub check { my $error = $self->ut_numbern('custnum') || $self->ut_number('agentnum') + || $self->ut_textn('agent_custid') || $self->ut_number('refnum') || $self->ut_name('last') || $self->ut_name('first') + || $self->ut_snumbern('birthdate') + || $self->ut_snumbern('signupdate') || $self->ut_textn('company') || $self->ut_text('address1') || $self->ut_textn('address2') @@ -1169,7 +1323,10 @@ sub check { } } - $self->payby =~ /^(CARD|DCRD|CHEK|DCHK|LECB|BILL|COMP|PREPAY|CASH|WEST|MCRD)$/ + #$self->payby =~ /^(CARD|DCRD|CHEK|DCHK|LECB|BILL|COMP|PREPAY|CASH|WEST|MCRD)$/ + # or return "Illegal payby: ". $self->payby; + #$self->payby($1); + FS::payby->can_payby($self->table, $self->payby) or return "Illegal payby: ". $self->payby; $error = $self->ut_numbern('paystart_month') @@ -1194,8 +1351,6 @@ sub check { $check_payinfo = 0; } - $self->payby($1); - if ( $check_payinfo && $self->payby =~ /^(CARD|DCRD)$/ ) { my $payinfo = $self->payinfo; @@ -1211,22 +1366,25 @@ sub check { if cardtype($self->payinfo) eq "Unknown"; my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref); - return "Banned credit card" if $ban; - - if ( defined $self->dbdef_table->column('paycvv') ) { - if (length($self->paycvv) && !$self->is_encrypted($self->paycvv)) { - if ( cardtype($self->payinfo) eq 'American Express card' ) { - $self->paycvv =~ /^(\d{4})$/ - or return "CVV2 (CID) for American Express cards is four digits."; - $self->paycvv($1); - } else { - $self->paycvv =~ /^(\d{3})$/ - or return "CVV2 (CVC2/CID) is three digits."; - $self->paycvv($1); - } + if ( $ban ) { + return 'Banned credit card: banned on '. + time2str('%a %h %o at %r', $ban->_date). + ' by '. $ban->otaker. + ' (ban# '. $ban->bannum. ')'; + } + + if (length($self->paycvv) && !$self->is_encrypted($self->paycvv)) { + if ( cardtype($self->payinfo) eq 'American Express card' ) { + $self->paycvv =~ /^(\d{4})$/ + or return "CVV2 (CID) for American Express cards is four digits."; + $self->paycvv($1); } else { - $self->paycvv(''); + $self->paycvv =~ /^(\d{3})$/ + or return "CVV2 (CVC2/CID) is three digits."; + $self->paycvv($1); } + } else { + $self->paycvv(''); } my $cardtype = cardtype($payinfo); @@ -1257,13 +1415,23 @@ sub check { my $payinfo = $self->payinfo; $payinfo =~ s/[^\d\@]//g; - $payinfo =~ /^(\d+)\@(\d{9})$/ or return 'invalid echeck account@aba'; - $payinfo = "$1\@$2"; + if ( $conf->exists('echeck-nonus') ) { + $payinfo =~ /^(\d+)\@(\d+)$/ or return 'invalid echeck account@aba'; + $payinfo = "$1\@$2"; + } else { + $payinfo =~ /^(\d+)\@(\d{9})$/ or return 'invalid echeck account@aba'; + $payinfo = "$1\@$2"; + } $self->payinfo($payinfo); - $self->paycvv('') if $self->dbdef_table->column('paycvv'); + $self->paycvv(''); my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref); - return "Banned ACH account" if $ban; + if ( $ban ) { + return 'Banned ACH account: banned on '. + time2str('%a %h %o at %r', $ban->_date). + ' by '. $ban->otaker. + ' (ban# '. $ban->bannum. ')'; + } } elsif ( $self->payby eq 'LECB' ) { @@ -1272,24 +1440,27 @@ sub check { $payinfo =~ /^1?(\d{10})$/ or return 'invalid btn billing telephone number'; $payinfo = $1; $self->payinfo($payinfo); - $self->paycvv('') if $self->dbdef_table->column('paycvv'); + $self->paycvv(''); } elsif ( $self->payby eq 'BILL' ) { $error = $self->ut_textn('payinfo'); return "Illegal P.O. number: ". $self->payinfo if $error; - $self->paycvv('') if $self->dbdef_table->column('paycvv'); + $self->paycvv(''); } elsif ( $self->payby eq 'COMP' ) { - if ( !$self->custnum && $conf->config('users-allow_comp') ) { + my $curuser = $FS::CurrentUser::CurrentUser; + if ( ! $self->custnum + && ! $curuser->access_right('Complimentary customer') + ) + { return "You are not permitted to create complimentary accounts." - unless grep { $_ eq getotaker } $conf->config('users-allow_comp'); } $error = $self->ut_textn('payinfo'); return "Illegal comp account issuer: ". $self->payinfo if $error; - $self->paycvv('') if $self->dbdef_table->column('paycvv'); + $self->paycvv(''); } elsif ( $self->payby eq 'PREPAY' ) { @@ -1300,12 +1471,12 @@ sub check { return "Illegal prepayment identifier: ". $self->payinfo if $error; return "Unknown prepayment identifier" unless qsearchs('prepay_credit', { 'identifier' => $self->payinfo } ); - $self->paycvv('') if $self->dbdef_table->column('paycvv'); + $self->paycvv(''); } if ( $self->paydate eq '' || $self->paydate eq '-' ) { - return "Expriation date required" + return "Expiration date required" unless $self->payby =~ /^(BILL|PREPAY|CHEK|DCHK|LECB|CASH|WEST|MCRD)$/; $self->paydate(''); } else { @@ -1336,8 +1507,10 @@ sub check { $self->payname($1); } - $self->tax =~ /^(Y?)$/ or return "Illegal tax: ". $self->tax; - $self->tax($1); + foreach my $flag (qw( tax spool_cdr )) { + $self->$flag() =~ /^(Y?)$/ or return "Illegal $flag: ". $self->$flag(); + $self->$flag($1); + } $self->otaker(getotaker) unless $self->otaker; @@ -1355,11 +1528,17 @@ Returns all packages (see L<FS::cust_pkg>) for this customer. sub all_pkgs { my $self = shift; + + return $self->num_pkgs unless wantarray; + + my @cust_pkg = (); if ( $self->{'_pkgnum'} ) { - values %{ $self->{'_pkgnum'}->cache }; + @cust_pkg = values %{ $self->{'_pkgnum'}->cache }; } else { - qsearch( 'cust_pkg', { 'custnum' => $self->custnum }); + @cust_pkg = qsearch( 'cust_pkg', { 'custnum' => $self->custnum }); } + + sort sort_packages @cust_pkg; } =item ncancelled_pkgs @@ -1370,19 +1549,43 @@ Returns all non-cancelled packages (see L<FS::cust_pkg>) for this customer. sub ncancelled_pkgs { my $self = shift; + + return $self->num_ncancelled_pkgs unless wantarray; + + my @cust_pkg = (); if ( $self->{'_pkgnum'} ) { - grep { ! $_->getfield('cancel') } values %{ $self->{'_pkgnum'}->cache }; + + @cust_pkg = grep { ! $_->getfield('cancel') } + values %{ $self->{'_pkgnum'}->cache }; + } else { - @{ [ # force list context + + @cust_pkg = qsearch( 'cust_pkg', { - 'custnum' => $self->custnum, - 'cancel' => '', - }), + 'custnum' => $self->custnum, + 'cancel' => '', + }); + push @cust_pkg, qsearch( 'cust_pkg', { - 'custnum' => $self->custnum, - 'cancel' => 0, - }), - ] }; + 'custnum' => $self->custnum, + 'cancel' => 0, + }); + } + + sort sort_packages @cust_pkg; + +} + +# This should be generalized to use config options to determine order. +sub sort_packages { + if ( $a->get('cancel') and $b->get('cancel') ) { + $a->pkgnum <=> $b->pkgnum; + } elsif ( $a->get('cancel') or $b->get('cancel') ) { + return -1 if $b->get('cancel'); + return 1 if $a->get('cancel'); + return 0; + } else { + $a->pkgnum <=> $b->pkgnum; } } @@ -1431,14 +1634,18 @@ customer. =cut sub num_cancelled_pkgs { - my $self = shift; - $self->num_pkgs("cancel IS NOT NULL AND cust_pkg.cancel != 0"); + shift->num_pkgs("cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0"); +} + +sub num_ncancelled_pkgs { + shift->num_pkgs("( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )"); } sub num_pkgs { my( $self, $sql ) = @_; + $sql = "AND $sql" if $sql && $sql !~ /^\s*$/ && $sql !~ /^\s*AND/i; my $sth = dbh->prepare( - "SELECT COUNT(*) FROM cust_pkg WHERE custnum = ? AND $sql" + "SELECT COUNT(*) FROM cust_pkg WHERE custnum = ? $sql" ) or die dbh->errstr; $sth->execute($self->custnum) or die $sth->errstr; $sth->fetchrow_arrayref->[0]; @@ -1467,7 +1674,7 @@ Returns a list: an empty list on success or a list of errors. sub suspend { my $self = shift; - grep { $_->suspend } $self->unsuspended_pkgs; + grep { $_->suspend(@_) } $self->unsuspended_pkgs; } =item suspend_if_pkgpart PKGPART [ , PKGPART ... ] @@ -1481,8 +1688,14 @@ Returns a list: an empty list on success or a list of errors. sub suspend_if_pkgpart { my $self = shift; - my @pkgparts = @_; - grep { $_->suspend } + my (@pkgparts, %opt); + if (ref($_[0]) eq 'HASH'){ + @pkgparts = @{$_[0]{pkgparts}}; + %opt = %{$_[0]}; + }else{ + @pkgparts = @_; + } + grep { $_->suspend(%opt) } grep { my $pkgpart = $_->pkgpart; grep { $pkgpart eq $_ } @pkgparts } $self->unsuspended_pkgs; } @@ -1498,8 +1711,14 @@ Returns a list: an empty list on success or a list of errors. sub suspend_unless_pkgpart { my $self = shift; - my @pkgparts = @_; - grep { $_->suspend } + my (@pkgparts, %opt); + if (ref($_[0]) eq 'HASH'){ + @pkgparts = @{$_[0]{pkgparts}}; + %opt = %{$_[0]}; + }else{ + @pkgparts = @_; + } + grep { $_->suspend(%opt) } grep { my $pkgpart = $_->pkgpart; ! grep { $pkgpart eq $_ } @pkgparts } $self->unsuspended_pkgs; } @@ -1554,10 +1773,26 @@ sub _banned_pay_hashref { { 'payby' => $payby2ban{$self->payby}, 'payinfo' => md5_base64($self->payinfo), - #'reason' => + #don't ever *search* on reason! #'reason' => }; } +=item notes + +Returns all notes (see L<FS::cust_main_note>) for this customer. + +=cut + +sub notes { + my $self = shift; + #order by? + qsearch( 'cust_main_note', + { 'custnum' => $self->custnum }, + '', + 'ORDER BY _DATE DESC' + ); +} + =item agent Returns the agent (see L<FS::agent>) for this customer. @@ -1617,17 +1852,30 @@ sub bill { $self->select_for_update; #mutex + #create a new invoice + #(we'll remove it later if it doesn't actually need to be generated [contains + # no line items] and we're inside a transaciton so nothing else will see it) + my $cust_bill = new FS::cust_bill ( { + 'custnum' => $self->custnum, + '_date' => $time, + #'charged' => $charged, + 'charged' => 0, + } ); + $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; + + ### # 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 = (); - #my $tax = 0;## - #my $taxable_charged = 0;## - #my $charged = 0;## + ### + my( $total_setup, $total_recur ) = ( 0, 0 ); my %tax; + my @precommit_hooks = (); foreach my $cust_pkg ( qsearch('cust_pkg', { 'custnum' => $self->custnum } ) @@ -1649,22 +1897,28 @@ sub bill { my @details = (); + ### # bill setup + ### + my $setup = 0; if ( !$cust_pkg->setup || $options{'resetup'} ) { warn " bill setup\n" if $DEBUG > 1; - $setup = eval { $cust_pkg->calc_setup( $time ) }; + $setup = eval { $cust_pkg->calc_setup( $time, \@details ) }; if ( $@ ) { $dbh->rollback if $oldAutoCommit; - return $@; + return "$@ running calc_setup for $cust_pkg\n"; } $cust_pkg->setfield('setup', $time) unless $cust_pkg->setup; } - #bill recurring fee + ### + # bill recurring fee + ### + my $recur = 0; my $sdate; if ( $part_pkg->getfield('freq') ne '0' && @@ -1677,10 +1931,13 @@ sub bill { # XXX shared with $recur_prog $sdate = $cust_pkg->bill || $cust_pkg->setup || $time; - $recur = eval { $cust_pkg->calc_recur( \$sdate, \@details ) }; + #over two params! lets at least switch to a hashref for the rest... + my %param = ( 'precommit_hooks' => \@precommit_hooks, ); + + $recur = eval { $cust_pkg->calc_recur( \$sdate, \@details, \%param ) }; if ( $@ ) { $dbh->rollback if $oldAutoCommit; - return $@; + return "$@ running calc_recur for $cust_pkg\n"; } #change this bit to use Date::Manip? CAREFUL with timezones (see @@ -1719,12 +1976,18 @@ sub bill { warn "\$recur is undefined" unless defined($recur); warn "\$cust_pkg->bill is undefined" unless defined($cust_pkg->bill); - if ( $cust_pkg->modified ) { + ### + # If $cust_pkg has been modified, update it and create cust_bill_pkg records + ### + + if ( $cust_pkg->modified ) { # hmmm.. and if the options are modified? warn " package ". $cust_pkg->pkgnum. " modified; updating\n" if $DEBUG >1; - $error=$cust_pkg->replace($old_cust_pkg); + $error=$cust_pkg->replace($old_cust_pkg, + options => { $cust_pkg->options }, + ); if ( $error ) { #just in case $dbh->rollback if $oldAutoCommit; return "Error modifying pkgnum ". $cust_pkg->pkgnum. ": $error"; @@ -1740,10 +2003,13 @@ sub bill { $dbh->rollback if $oldAutoCommit; return "negative recur $recur for pkgnum ". $cust_pkg->pkgnum; } + if ( $setup != 0 || $recur != 0 ) { - warn " charges (setup=$setup, recur=$recur); queueing line items\n" + + warn " charges (setup=$setup, recur=$recur); adding line items\n" if $DEBUG > 1; my $cust_bill_pkg = new FS::cust_bill_pkg ({ + 'invnum' => $invnum, 'pkgnum' => $cust_pkg->pkgnum, 'setup' => $setup, 'recur' => $recur, @@ -1751,35 +2017,40 @@ sub bill { 'edate' => $cust_pkg->bill, 'details' => \@details, }); - push @cust_bill_pkg, $cust_bill_pkg; + $error = $cust_bill_pkg->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "can't create invoice line item for invoice #$invnum: $error"; + } $total_setup += $setup; $total_recur += $recur; + ### + # handle taxes + ### + unless ( $self->tax =~ /Y/i || $self->payby eq 'COMP' ) { - my @taxes = qsearch( 'cust_main_county', { - 'state' => $self->state, - 'county' => $self->county, - 'country' => $self->country, - 'taxclass' => $part_pkg->taxclass, - } ); + my $prefix = + ( $conf->exists('tax-ship_address') && length($self->ship_last) ) + ? 'ship_' + : ''; + my %taxhash = map { $_ => $self->get("$prefix$_") } + qw( state county country ); + + $taxhash{'taxclass'} = $part_pkg->taxclass; + + my @taxes = qsearch( 'cust_main_county', \%taxhash ); + unless ( @taxes ) { - @taxes = qsearch( 'cust_main_county', { - 'state' => $self->state, - 'county' => $self->county, - 'country' => $self->country, - 'taxclass' => '', - } ); + $taxhash{'taxclass'} = ''; + @taxes = qsearch( 'cust_main_county', \%taxhash ); } #one more try at a whole-country tax rate unless ( @taxes ) { - @taxes = qsearch( 'cust_main_county', { - 'state' => '', - 'county' => '', - 'country' => $self->country, - 'taxclass' => '', - } ); + $taxhash{$_} = '' foreach qw( state county ); + @taxes = qsearch( 'cust_main_county', \%taxhash ); } # maybe eliminate this entirely, along with all the 0% records @@ -1787,8 +2058,10 @@ sub bill { $dbh->rollback if $oldAutoCommit; return "fatal: can't find tax rate for state/county/country/taxclass ". - join('/', ( map $self->$_(), qw(state county country) ), - $part_pkg->taxclass ). "\n"; + join('/', ( map $self->get("$prefix$_"), + qw(state county country) + ), + $part_pkg->taxclass ). "\n"; } foreach my $tax ( @taxes ) { @@ -1803,7 +2076,8 @@ sub bill { next unless $taxable_charged; if ( $tax->exempt_amount && $tax->exempt_amount > 0 ) { - my ($mon,$year) = (localtime($sdate) )[4,5]; + #my ($mon,$year) = (localtime($sdate) )[4,5]; + my ($mon,$year) = (localtime( $sdate || $cust_bill->_date ) )[4,5]; $mon++; my $freq = $part_pkg->freq || 1; if ( $freq !~ /(\d+)$/ ) { @@ -1811,40 +2085,74 @@ sub bill { return "daily/weekly package definitions not (yet?)". " compatible with monthly tax exemptions"; } - my $taxable_per_month = sprintf("%.2f", $taxable_charged / $freq ); + my $taxable_per_month = + sprintf("%.2f", $taxable_charged / $freq ); + + #call the whole thing off if this customer has any old + #exemption records... + my @cust_tax_exempt = + qsearch( 'cust_tax_exempt' => { custnum=> $self->custnum } ); + if ( @cust_tax_exempt ) { + $dbh->rollback if $oldAutoCommit; + return + 'this customer still has old-style tax exemption records; '. + 'run bin/fs-migrate-cust_tax_exempt?'; + } + foreach my $which_month ( 1 .. $freq ) { - my %hash = ( - 'custnum' => $self->custnum, - 'taxnum' => $tax->taxnum, - 'year' => 1900+$year, - 'month' => $mon++, - ); - #until ( $mon < 12 ) { $mon -= 12; $year++; } - until ( $mon < 13 ) { $mon -= 12; $year++; } - my $cust_tax_exempt = - qsearchs('cust_tax_exempt', \%hash) - || new FS::cust_tax_exempt( { %hash, 'amount' => 0 } ); - my $remaining_exemption = sprintf("%.2f", - $tax->exempt_amount - $cust_tax_exempt->amount ); + + #maintain the new exemption table now + my $sql = " + SELECT SUM(amount) + FROM cust_tax_exempt_pkg + LEFT JOIN cust_bill_pkg USING ( billpkgnum ) + LEFT JOIN cust_bill USING ( invnum ) + WHERE custnum = ? + AND taxnum = ? + AND year = ? + AND month = ? + "; + my $sth = dbh->prepare($sql) or do { + $dbh->rollback if $oldAutoCommit; + return "fatal: can't lookup exising exemption: ". dbh->errstr; + }; + $sth->execute( + $self->custnum, + $tax->taxnum, + 1900+$year, + $mon, + ) or do { + $dbh->rollback if $oldAutoCommit; + return "fatal: can't lookup exising exemption: ". dbh->errstr; + }; + my $existing_exemption = $sth->fetchrow_arrayref->[0] || 0; + + my $remaining_exemption = + $tax->exempt_amount - $existing_exemption; if ( $remaining_exemption > 0 ) { my $addl = $remaining_exemption > $taxable_per_month ? $taxable_per_month : $remaining_exemption; $taxable_charged -= $addl; - my $new_cust_tax_exempt = new FS::cust_tax_exempt ( { - $cust_tax_exempt->hash, - 'amount' => - sprintf("%.2f", $cust_tax_exempt->amount + $addl), + + my $cust_tax_exempt_pkg = new FS::cust_tax_exempt_pkg ( { + 'billpkgnum' => $cust_bill_pkg->billpkgnum, + 'taxnum' => $tax->taxnum, + 'year' => 1900+$year, + 'month' => $mon, + 'amount' => sprintf("%.2f", $addl ), } ); - $error = $new_cust_tax_exempt->exemptnum - ? $new_cust_tax_exempt->replace($cust_tax_exempt) - : $new_cust_tax_exempt->insert; + $error = $cust_tax_exempt_pkg->insert; if ( $error ) { $dbh->rollback if $oldAutoCommit; - return "fatal: can't update cust_tax_exempt: $error"; + return "fatal: can't insert cust_tax_exempt_pkg: $error"; } - } # if $remaining_exemption > 0 + + #++ + $mon++; + #until ( $mon < 12 ) { $mon -= 12; $year++; } + until ( $mon < 13 ) { $mon -= 12; $year++; } } #foreach $which_month @@ -1866,85 +2174,50 @@ sub bill { } #foreach my $cust_pkg - my $charged = sprintf( "%.2f", $total_setup + $total_recur ); -# my $taxable_charged = sprintf( "%.2f", $taxable_setup + $taxable_recur ); - - unless ( @cust_bill_pkg ) { #don't create invoices with no line items + unless ( $cust_bill->cust_bill_pkg ) { + $cust_bill->delete; #don't create an invoice w/o line items $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, -# } ) or die "fatal: can't find tax rate for state/county/country ". -# $self->state. "/". $self->county. "/". $self->country. "\n"; -# my $tax = sprintf( "%.2f", -# $taxable_charged * ( $cust_main_county->getfield('tax') / 100 ) -# ); - - if ( dbdef->table('cust_bill_pkg')->column('itemdesc') ) { #1.5 schema - - foreach my $taxname ( grep { $tax{$_} > 0 } keys %tax ) { - my $tax = sprintf("%.2f", $tax{$taxname} ); - $charged = sprintf( "%.2f", $charged+$tax ); - - my $cust_bill_pkg = new FS::cust_bill_pkg ({ - 'pkgnum' => 0, - 'setup' => $tax, - 'recur' => 0, - 'sdate' => '', - 'edate' => '', - 'itemdesc' => $taxname, - }); - push @cust_bill_pkg, $cust_bill_pkg; - } + } + + my $charged = sprintf( "%.2f", $total_setup + $total_recur ); + + foreach my $taxname ( grep { $tax{$_} > 0 } keys %tax ) { + my $tax = sprintf("%.2f", $tax{$taxname} ); + $charged = sprintf( "%.2f", $charged+$tax ); - } else { #1.4 schema - - my $tax = 0; - foreach ( values %tax ) { $tax += $_ }; - $tax = sprintf("%.2f", $tax); - 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_pkg = new FS::cust_bill_pkg ({ + 'invnum' => $invnum, + 'pkgnum' => 0, + 'setup' => $tax, + 'recur' => 0, + 'sdate' => '', + 'edate' => '', + 'itemdesc' => $taxname, + }); + $error = $cust_bill_pkg->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "can't create invoice line item for invoice #$invnum: $error"; } + $total_setup += $tax; } - my $cust_bill = new FS::cust_bill ( { - 'custnum' => $self->custnum, - '_date' => $time, - 'charged' => $charged, - } ); - $error = $cust_bill->insert; + $cust_bill->charged( sprintf( "%.2f", $total_setup + $total_recur ) ); + $error = $cust_bill->replace; if ( $error ) { $dbh->rollback if $oldAutoCommit; - return "can't create invoice for customer #". $self->custnum. ": $error"; + return "can't update charged for invoice #$invnum: $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 ) { + foreach my $hook ( @precommit_hooks ) { + eval { + &{$hook}; #($self) ? + }; + if ( $@ ) { $dbh->rollback if $oldAutoCommit; - return "can't create invoice line item for customer #". $self->custnum. - ": $error"; + return "$@ running precommit hook $hook\n"; } } @@ -1977,16 +2250,12 @@ for conversion functions. retry - Retry card/echeck/LEC transactions even when not scheduled by invoice events. -retry_card - Deprecated alias for 'retry' - -batch_card - This option is deprecated. See the invoice events web interface -to control whether cards are batched or run against a realtime gateway. +quiet - set true to surpress email card/ACH decline notices. -report_badcard - This option is deprecated. +freq - "1d" for the traditional, daily events (the default), or "1m" for the +new monthly events -force_print - This option is deprecated; see the invoice events web interface. - -quiet - set true to surpress email card/ACH decline notices. +payby - allows for one time override of normal customer billing method =cut @@ -2028,6 +2297,13 @@ sub collect { } } + my $extra_sql = ''; + if ( defined $options{'freq'} && $options{'freq'} eq '1m' ) { + $extra_sql = " AND freq = '1m' "; + } else { + $extra_sql = " AND ( freq = '1d' OR freq IS NULL OR freq = '' ) "; + } + foreach my $cust_bill ( $self->open_cust_bill ) { # don't try to charge for the same invoice if it's already in a batch @@ -2038,72 +2314,28 @@ sub collect { warn " invnum ". $cust_bill->invnum. " (owed ". $cust_bill->owed. ")\n" if $DEBUG > 1; - 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 ) - && ! qsearch( 'cust_bill_event', { - 'invnum' => $cust_bill->invnum, - 'eventpart' => $_->eventpart, - 'status' => 'done', - } ) - } - qsearch('part_bill_event', { 'payby' => $self->payby, - 'disabled' => '', } ) - ) { + foreach my $part_bill_event ( due_events ( $cust_bill, + exists($options{'payby'}) + ? $options{'payby'} + : $self->payby, + $invoice_time, + $extra_sql ) ) { last if $cust_bill->owed <= 0 # don't run subsequent events if owed<=0 || $self->balance <= 0; # or if balance<=0 - warn " calling invoice event (". $part_bill_event->eventcode. ")\n" - if $DEBUG > 1; - my $cust_main = $self; #for callback - - my $error; { local $realtime_bop_decline_quiet = 1 if $options{'quiet'}; - local $SIG{__DIE__}; # don't want Mason __DIE__ handler active - $error = eval $part_bill_event->eventcode; - } - - my $status = ''; - my $statustext = ''; - if ( $@ ) { - $status = 'failed'; - $statustext = $@; - } elsif ( $error ) { - $status = 'done'; - $statustext = $error; - } else { - $status = 'done' - } - - #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, - '_date' => time, - 'status' => $status, - 'statustext' => $statustext, - }; - $error = $cust_bill_event->insert; - if ( $error ) { - #$dbh->rollback if $oldAutoCommit; - #return "error: $error"; + warn " do_event " . $cust_bill . " ". (%options) . "\n" + if $DEBUG > 1; - # 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; + if (my $error = $part_bill_event->do_event($cust_bill, %options)) { + # gah, even with transactions. + $dbh->commit if $oldAutoCommit; #well. + return $error; + } } - } } @@ -2115,9 +2347,10 @@ sub collect { =item retry_realtime -Schedules realtime credit card / electronic check / LEC billing events for -for retry. Useful if card information has changed or manual retry is desired. -The 'collect' method must be called to actually retry the transaction. +Schedules realtime / batch credit card / electronic check / LEC billing +events for for retry. Useful if card information has changed or manual +retry is desired. The 'collect' method must be called to actually retry +the transaction. Implementation details: For each of this customer's open invoices, changes the status of the first "done" (with statustext error) realtime processing @@ -2148,7 +2381,7 @@ sub retry_realtime { grep { #$_->part_bill_event->plan eq 'realtime-card' $_->part_bill_event->eventcode =~ - /\$cust_bill\->realtime_(card|ach|lec)/ + /\$cust_bill\->(batch|realtime)_(card|ach|lec)/ && $_->status eq 'done' && $_->statustext } @@ -2184,7 +2417,7 @@ if set, will override the value from the customer record. I<description> is a free-text field passed to the gateway. It defaults to "Internet services". -If an I<invnum> is specified, this payment (if sucessful) is applied to the +If an I<invnum> is specified, this payment (if successful) is applied to the specified invoice. If you don't specify an I<invnum> you might want to call the B<apply_payments> method. @@ -2298,8 +2531,9 @@ sub realtime_bop { $payname = "$payfirst $paylast"; } - my @invoicing_list = grep { $_ ne 'POST' } $self->invoicing_list; - if ( $conf->exists('emailinvoiceauto') + my @invoicing_list = $self->invoicing_list_emailonly; + if ( $conf->exists('emailinvoiceautoalways') + || $conf->exists('emailinvoiceauto') && ! @invoicing_list || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) { push @invoicing_list, $self->all_emails; } @@ -2316,6 +2550,9 @@ sub realtime_bop { $content{customer_ip} = $payip if length($payip); + $content{invoice_number} = $options{'invnum'} + if exists($options{'invnum'}) && length($options{'invnum'}); + if ( $method eq 'CC' ) { $content{card_number} = $payinfo; @@ -2351,8 +2588,13 @@ sub realtime_bop { if qsearch('cust_pay', { 'custnum' => $self->custnum, 'payby' => 'CARD', 'payinfo' => $payinfo, + } ) + || qsearch('cust_pay', { 'custnum' => $self->custnum, + 'payby' => 'CARD', + 'paymask' => $self->mask_payinfo('CARD', $payinfo), } ); + } elsif ( $method eq 'ECHECK' ) { ( $content{account_number}, $content{routing_code} ) = split('@', $payinfo); @@ -2381,7 +2623,7 @@ sub realtime_bop { 'action' => $action1, 'description' => $options{'description'}, 'amount' => $amount, - 'invoice_number' => $options{'invnum'}, + #'invoice_number' => $options{'invnum'}, 'customer_id' => $self->custnum, 'last_name' => $paylast, 'first_name' => $payfirst, @@ -2427,7 +2669,8 @@ sub realtime_bop { description => $options{'description'}, ); - foreach my $field (qw( authorization_source_code returned_ACI transaction_identifier validation_code + foreach my $field (qw( authorization_source_code returned_ACI + transaction_identifier validation_code transaction_sequence_num local_transaction_date local_transaction_time AVS_result_code )) { $capture{$field} = $transaction->$field() if $transaction->can($field); @@ -2438,7 +2681,7 @@ sub realtime_bop { $capture->submit(); unless ( $capture->is_success ) { - my $e = "Authorization sucessful but capture failed, custnum #". + my $e = "Authorization successful but capture failed, custnum #". $self->custnum. ': '. $capture->result_code. ": ". $capture->error_message; warn $e; @@ -2495,10 +2738,12 @@ sub realtime_bop { 'payinfo' => $payinfo, 'paybatch' => $paybatch, } ); - my $error = $cust_pay->insert; + my $error = $cust_pay->insert($options{'manual'} ? ( 'manual' => 1 ) : () ); if ( $error ) { $cust_pay->invnum(''); #try again with no specific invnum - my $error2 = $cust_pay->insert; + my $error2 = $cust_pay->insert( $options{'manual'} ? + ( 'manual' => 1 ) : () + ); if ( $error2 ) { # gah, even with transactions. my $e = 'WARNING: Card/ACH debited but database not updated - '. @@ -2618,7 +2863,7 @@ gateway is attempted. #I<zip>, I<payinfo> and I<paydate> are also available. Any of these options, #if set, will override the value from the customer record. -#If an I<invnum> is specified, this payment (if sucessful) is applied to the +#If an I<invnum> is specified, this payment (if successful) is applied to the #specified invoice. If you don't specify an I<invnum> you might want to #call the B<apply_payments> method. @@ -2775,6 +3020,23 @@ sub realtime_refund_bop { $payname = "$payfirst $paylast"; } + my @invoicing_list = $self->invoicing_list_emailonly; + if ( $conf->exists('emailinvoiceautoalways') + || $conf->exists('emailinvoiceauto') && ! @invoicing_list + || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) { + push @invoicing_list, $self->all_emails; + } + + my $email = ($conf->exists('business-onlinepayment-email-override')) + ? $conf->config('business-onlinepayment-email-override') + : $invoicing_list[0]; + + my $payip = exists($options{'payip'}) + ? $options{'payip'} + : $self->payip; + $content{customer_ip} = $payip + if length($payip); + my $payinfo = ''; if ( $method eq 'CC' ) { @@ -2813,6 +3075,8 @@ sub realtime_refund_bop { 'state' => $self->state, 'zip' => $self->zip, 'country' => $self->country, + 'email' => $email, + 'phone' => $self->daytime || $self->night, %content, #after ); warn join('', map { " $_ => $sub_content{$_}\n" } keys %sub_content ) @@ -2832,7 +3096,7 @@ sub realtime_refund_bop { $paybatch .= ':'. $refund->order_number if $refund->can('order_number') && $refund->order_number; - while ( $cust_pay && $cust_pay->unappled < $amount ) { + while ( $cust_pay && $cust_pay->unapplied < $amount ) { my @cust_bill_pay = $cust_pay->cust_bill_pay; last unless @cust_bill_pay; my $cust_bill_pay = pop @cust_bill_pay; @@ -2902,6 +3166,24 @@ sub total_owed_date { sprintf( "%.2f", $total_bill ); } +=item apply_payments_and_credits + +Applies unapplied payments and credits. + +In most cases, this new method should be used in place of sequential +apply_payments and apply_credits methods. + +=cut + +sub apply_payments_and_credits { + my $self = shift; + + foreach my $cust_bill ( $self->open_cust_bill ) { + $cust_bill->apply_payments_and_credits; + } + +} + =item apply_credits OPTION => VALUE ... Applies (see L<FS::cust_credit_bill>) unapplied credits (see L<FS::cust_credit>) @@ -3074,6 +3356,29 @@ sub balance_date { ); } +=item in_transit_payments + +Returns the total of requests for payments for this customer pending in +batches in transit to the bank. See L<FS::pay_batch> and L<FS::cust_pay_batch> + +=cut + +sub in_transit_payments { + my $self = shift; + my $in_transit_payments = 0; + foreach my $pay_batch ( qsearch('pay_batch', { + 'status' => 'I', + } ) ) { + foreach my $cust_pay_batch ( qsearch('cust_pay_batch', { + 'batchnum' => $pay_batch->batchnum, + 'custnum' => $self->custnum, + } ) ) { + $in_transit_payments += $cust_pay_batch->amount; + } + } + sprintf( "%.2f", $in_transit_payments ); +} + =item paydate_monthyear Returns a two-element list consisting of the month and year of this customer's @@ -3092,21 +3397,6 @@ sub paydate_monthyear { } } -=item payinfo_masked - -Returns a "masked" payinfo field appropriate to the payment type. Masked characters are replaced by 'x'es. Use this to display publicly accessable account Information. - -Credit Cards - Mask all but the last four characters. -Checks - Mask all but last 2 of account number and bank routing number. -Others - Do nothing, return the unmasked string. - -=cut - -sub payinfo_masked { - my $self = shift; - return $self->paymask; -} - =item invoicing_list [ ARRAYREF ] If an arguement is given, sets these email addresses as invoice recipients @@ -3124,6 +3414,7 @@ This interface may change in the future. sub invoicing_list { my( $self, $arrayref ) = @_; + if ( $arrayref ) { my @cust_main_invoice; if ( $self->custnum ) { @@ -3158,12 +3449,14 @@ sub invoicing_list { warn $error if $error; } } + if ( $self->custnum ) { map { $_->address } qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } ); } else { (); } + } =item check_invoicing_list ARRAYREF @@ -3241,6 +3534,34 @@ sub invoicing_list_addpost { $self->invoicing_list(\@invoicing_list); } +=item invoicing_list_emailonly + +Returns the list of email invoice recipients (invoicing_list without non-email +destinations such as POST and FAX). + +=cut + +sub invoicing_list_emailonly { + my $self = shift; + warn "$me invoicing_list_emailonly called" + if $DEBUG; + grep { $_ !~ /^([A-Z]+)$/ } $self->invoicing_list; +} + +=item invoicing_list_emailonly_scalar + +Returns the list of email invoice recipients (invoicing_list without non-email +destinations such as POST and FAX) as a comma-separated scalar. + +=cut + +sub invoicing_list_emailonly_scalar { + my $self = shift; + warn "$me invoicing_list_emailonly_scalar called" + if $DEBUG; + join(', ', $self->invoicing_list_emailonly); +} + =item referral_cust_main [ DEPTH [ EXCLUDE_HASHREF ] ] Returns an array of customers referred by this customer (referral_custnum set @@ -3336,10 +3657,22 @@ the error, otherwise returns false. =cut sub charge { - my ( $self, $amount ) = ( shift, shift ); - my $pkg = @_ ? shift : 'One-time charge'; - my $comment = @_ ? shift : '$'. sprintf("%.2f",$amount); - my $taxclass = @_ ? shift : ''; + my $self = shift; + my ( $amount, $pkg, $comment, $taxclass, $additional ); + if ( ref( $_[0] ) ) { + $amount = $_[0]->{amount}; + $pkg = exists($_[0]->{pkg}) ? $_[0]->{pkg} : 'One-time charge'; + $comment = exists($_[0]->{comment}) ? $_[0]->{comment} + : '$'. sprintf("%.2f",$amount); + $taxclass = exists($_[0]->{taxclass}) ? $_[0]->{taxclass} : ''; + $additional = $_[0]->{additional}; + }else{ + $amount = shift; + $pkg = @_ ? shift : 'One-time charge'; + $comment = @_ ? shift : '$'. sprintf("%.2f",$amount); + $taxclass = @_ ? shift : ''; + $additional = []; + } local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; @@ -3355,16 +3688,20 @@ sub charge { my $part_pkg = new FS::part_pkg ( { 'pkg' => $pkg, 'comment' => $comment, - #'setup' => $amount, - #'recur' => '0', 'plan' => 'flat', - 'plandata' => "setup_fee=$amount", 'freq' => 0, 'disabled' => 'Y', 'taxclass' => $taxclass, } ); - my $error = $part_pkg->insert; + my %options = ( ( map { ("additional_info$_" => $additional->[$_] ) } + ( 0 .. @$additional - 1 ) + ), + 'additional_count' => scalar(@$additional), + 'setup_fee' => $amount, + ); + + my $error = $part_pkg->insert( options => \%options ); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; @@ -3470,18 +3807,6 @@ sub cust_refund { qsearch( 'cust_refund', { 'custnum' => $self->custnum } ) } -=item select_for_update - -Selects this record with the SQL "FOR UPDATE" command. This can be useful as -a mutex. - -=cut - -sub select_for_update { - my $self = shift; - qsearch('cust_main', { 'custnum' => $self->custnum }, '*', 'FOR UPDATE' ); -} - =item name Returns a name string for this customer, either "Company (Last, First)" or @@ -3538,6 +3863,19 @@ sub ship_contact { : $self->contact; } +=item country_full + +Returns this customer's full country name + +=cut + +sub country_full { + my $self = shift; + code2country($self->country); +} + +=item cust_status + =item status Returns a status string for this customer, currently: @@ -3548,6 +3886,8 @@ Returns a status string for this customer, currently: =item active - One or more recurring packages is active +=item inactive - No active recurring packages, but otherwise unsuspended/uncancelled (the inactive status is new - previously inactive customers were mis-identified as cancelled) + =item suspended - All non-cancelled recurring packages are suspended =item cancelled - All recurring packages are cancelled @@ -3556,32 +3896,55 @@ Returns a status string for this customer, currently: =cut -sub status { +sub status { shift->cust_status(@_); } + +sub cust_status { my $self = shift; - for my $status (qw( prospect active suspended cancelled )) { + for my $status (qw( prospect active inactive suspended cancelled )) { my $method = $status.'_sql'; my $numnum = ( my $sql = $self->$method() ) =~ s/cust_main\.custnum/?/g; my $sth = dbh->prepare("SELECT $sql") or die dbh->errstr; - $sth->execute( ($self->custnum) x $numnum ) or die $sth->errstr; + $sth->execute( ($self->custnum) x $numnum ) + or die "Error executing 'SELECT $sql': ". $sth->errstr; return $status if $sth->fetchrow_arrayref->[0]; } } +=item ucfirst_cust_status + +=item ucfirst_status + +Returns the status with the first character capitalized. + +=cut + +sub ucfirst_status { shift->ucfirst_cust_status(@_); } + +sub ucfirst_cust_status { + my $self = shift; + ucfirst($self->cust_status); +} + =item statuscolor Returns a hex triplet color string for this customer's status. =cut -my %statuscolor = ( - 'prospect' => '000000', - 'active' => '00CC00', - 'suspended' => 'FF9900', - 'cancelled' => 'FF0000', +use vars qw(%statuscolor); +%statuscolor = ( + 'prospect' => '7e0079', #'000000', #black? naw, purple + 'active' => '00CC00', #green + 'inactive' => '0000CC', #blue + 'suspended' => 'FF9900', #yellow + 'cancelled' => 'FF0000', #red ); -sub statuscolor { + +sub statuscolor { shift->cust_statuscolor(@_); } + +sub cust_statuscolor { my $self = shift; - $statuscolor{$self->status}; + $statuscolor{$self->cust_status}; } =back @@ -3597,25 +3960,44 @@ with no packages ever ordered) =cut +use vars qw($select_count_pkgs); +$select_count_pkgs = + "SELECT COUNT(*) FROM cust_pkg + WHERE cust_pkg.custnum = cust_main.custnum"; + +sub select_count_pkgs_sql { + $select_count_pkgs; +} + sub prospect_sql { " - 0 = ( SELECT COUNT(*) FROM cust_pkg - WHERE cust_pkg.custnum = cust_main.custnum - ) + 0 = ( $select_count_pkgs ) "; } =item active_sql -Returns an SQL expression identifying active cust_main records. +Returns an SQL expression identifying active cust_main records (customers with +no active recurring packages, but otherwise unsuspended/uncancelled). =cut sub active_sql { " - 0 < ( SELECT COUNT(*) FROM cust_pkg - WHERE cust_pkg.custnum = cust_main.custnum - AND ". FS::cust_pkg->active_sql. " + 0 < ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " ) "; } +=item inactive_sql + +Returns an SQL expression identifying inactive cust_main records (customers with +active recurring packages). + +=cut + +sub inactive_sql { " + 0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " ) + AND + 0 < ( $select_count_pkgs AND ". FS::cust_pkg->inactive_sql. " ) +"; } + =item susp_sql =item suspended_sql @@ -3623,23 +4005,12 @@ Returns an SQL expression identifying suspended cust_main records. =cut -#my $recurring_sql = FS::cust_pkg->recurring_sql; -my $recurring_sql = " - '0' != ( select freq from part_pkg - where cust_pkg.pkgpart = part_pkg.pkgpart ) -"; sub suspended_sql { susp_sql(@_); } sub susp_sql { " - 0 < ( SELECT COUNT(*) FROM cust_pkg - WHERE cust_pkg.custnum = cust_main.custnum - AND $recurring_sql - AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 ) - ) - AND 0 = ( SELECT COUNT(*) FROM cust_pkg - WHERE cust_pkg.custnum = cust_main.custnum - AND ". FS::cust_pkg->active_sql. " - ) + 0 < ( $select_count_pkgs AND ". FS::cust_pkg->suspended_sql. " ) + AND + 0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " ) "; } =item cancel_sql @@ -3650,22 +4021,45 @@ Returns an SQL expression identifying cancelled cust_main records. =cut sub cancelled_sql { cancel_sql(@_); } -sub cancel_sql { " - 0 < ( SELECT COUNT(*) FROM cust_pkg - WHERE cust_pkg.custnum = cust_main.custnum - ) - AND 0 = ( SELECT COUNT(*) FROM cust_pkg - WHERE cust_pkg.custnum = cust_main.custnum - AND $recurring_sql - AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 ) - ) +sub cancel_sql { + + my $recurring_sql = FS::cust_pkg->recurring_sql; + #my $recurring_sql = " + # '0' != ( select freq from part_pkg + # where cust_pkg.pkgpart = part_pkg.pkgpart ) + #"; + + " + 0 < ( $select_count_pkgs ) + AND 0 = ( $select_count_pkgs AND $recurring_sql + AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 ) + ) + "; +} + +=item uncancel_sql +=item uncancelled_sql + +Returns an SQL expression identifying un-cancelled cust_main records. + +=cut + +sub uncancelled_sql { uncancel_sql(@_); } +sub uncancel_sql { " + ( 0 < ( $select_count_pkgs + AND ( cust_pkg.cancel IS NULL + OR cust_pkg.cancel = 0 + ) + ) + OR 0 = ( $select_count_pkgs ) + ) "; } =item fuzzy_search FUZZY_HASHREF [ HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ ] Performs a fuzzy (approximate) search and returns the matching FS::cust_main -records. Currently, only I<last> or I<company> may be specified (the -appropriate ship_ field is also searched if applicable). +records. Currently, I<first>, I<last> and/or I<company> may be specified (the +appropriate ship_ field is also searched). Additional options are the same as FS::Record::qsearch @@ -3679,19 +4073,25 @@ sub fuzzy_search { check_and_rebuild_fuzzyfiles(); foreach my $field ( keys %$fuzzy ) { - my $sub = \&{"all_$field"}; + + my $all = $self->all_X($field); + next unless scalar(@$all); + my %match = (); - $match{$_}=1 foreach ( amatch($fuzzy->{$field}, ['i'], @{ &$sub() } ) ); + $match{$_}=1 foreach ( amatch( $fuzzy->{$field}, ['i'], @$all ) ); + my @fcust = (); foreach ( keys %match ) { - push @cust_main, qsearch('cust_main', { %$hash, $field=>$_}, @opt); - push @cust_main, qsearch('cust_main', { %$hash, "ship_$field"=>$_}, @opt) - if defined dbdef->table('cust_main')->column('ship_last'); + push @fcust, qsearch('cust_main', { %$hash, $field=>$_}, @opt); + push @fcust, qsearch('cust_main', { %$hash, "ship_$field"=>$_}, @opt); } + my %fsaw = (); + push @cust_main, grep { ! $fsaw{$_->custnum}++ } @fcust; } + # we want the components of $fuzzy ANDed, not ORed, but still don't want dupes my %saw = (); - @cust_main = grep { !$saw{$_->custnum}++ } @cust_main; + @cust_main = grep { ++$saw{$_->custnum} == scalar(keys %$fuzzy) } @cust_main; @cust_main; @@ -3706,10 +4106,11 @@ sub fuzzy_search { =item smart_search OPTION => VALUE ... Accepts the following options: I<search>, the string to search for. The string -will be searched for as a customer number, last name or company name, first -searching for an exact match then fuzzy and substring matches. +will be searched for as a customer number, phone number, name or company name, +as an exact, or, in some cases, a substring or fuzzy match (see the source code +for the exact heuristics used). -Any additional options treated as an additional qualifier on the search +Any additional options are treated as an additional qualifier on the search (i.e. I<agentnum>). Returns a (possibly empty) array of FS::cust_main objects. @@ -3718,72 +4119,215 @@ Returns a (possibly empty) array of FS::cust_main objects. sub smart_search { my %options = @_; - my $search = delete $options{'search'}; + + #here is the agent virtualization + my $agentnums_sql = $FS::CurrentUser::CurrentUser->agentnums_sql; + my @cust_main = (); - if ( $search =~ /^\s*(\d+)\s*$/ ) { # customer # search + my $search = delete $options{'search'}; + ( my $alphanum_search = $search ) =~ s/\W//g; + + if ( $alphanum_search =~ /^1?(\d{3})(\d{3})(\d{4})(\d*)$/ ) { #phone# search + + #false laziness w/Record::ut_phone + my $phonen = "$1-$2-$3"; + $phonen .= " x$4" if $4; + + push @cust_main, qsearch( { + 'table' => 'cust_main', + 'hashref' => { %options }, + 'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ). + ' ( '. + join(' OR ', map "$_ = '$phonen'", + qw( daytime night fax + ship_daytime ship_night ship_fax ) + ). + ' ) '. + " AND $agentnums_sql", #agent virtualization + } ); + + unless ( @cust_main || $phonen =~ /x\d+$/ ) { #no exact match + #try looking for matches with extensions unless one was specified + + push @cust_main, qsearch( { + 'table' => 'cust_main', + 'hashref' => { %options }, + 'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ). + ' ( '. + join(' OR ', map "$_ LIKE '$phonen\%'", + qw( daytime night + ship_daytime ship_night ) + ). + ' ) '. + " AND $agentnums_sql", #agent virtualization + } ); + + } + + } elsif ( $search =~ /^\s*(\d+)\s*$/ ) { # customer # search + + push @cust_main, qsearch( { + 'table' => 'cust_main', + 'hashref' => { 'custnum' => $1, %options }, + 'extra_sql' => " AND $agentnums_sql", #agent virtualization + } ); + + } elsif ( $search =~ /^\s*(\S.*\S)\s+\((.+), ([^,]+)\)\s*$/ ) { + + my($company, $last, $first) = ( $1, $2, $3 ); + + # "Company (Last, First)" + #this is probably something a browser remembered, + #so just do an exact search - push @cust_main, qsearch('cust_main', { 'custnum' => $1, %options } ); + foreach my $prefix ( '', 'ship_' ) { + push @cust_main, qsearch( { + 'table' => 'cust_main', + 'hashref' => { $prefix.'first' => $first, + $prefix.'last' => $last, + $prefix.'company' => $company, + %options, + }, + 'extra_sql' => " AND $agentnums_sql", + } ); + } - } elsif ( $search =~ /^\s*(\S.*\S)\s*$/ ) { #value search + } elsif ( $search =~ /^\s*(\S.*\S)\s*$/ ) { # value search + # try (ship_){last,company} my $value = lc($1); + + # # remove "(Last, First)" in "Company (Last, First)", otherwise the + # # full strings the browser remembers won't work + # $value =~ s/\([\w \,\.\-\']*\)$//; #false laziness w/Record::ut_name + + use Lingua::EN::NameParse; + my $NameParse = new Lingua::EN::NameParse( + auto_clean => 1, + allow_reversed => 1, + ); + + my($last, $first) = ( '', '' ); + #maybe disable this too and just rely on NameParse? + if ( $value =~ /^(.+),\s*([^,]+)$/ ) { # Last, First + + ($last, $first) = ( $1, $2 ); + + #} elsif ( $value =~ /^(.+)\s+(.+)$/ ) { + } elsif ( ! $NameParse->parse($value) ) { + + my %name = $NameParse->components; + $first = $name{'given_name_1'}; + $last = $name{'surname_1'}; + + } + + if ( $first && $last ) { + + my($q_last, $q_first) = ( dbh->quote($last), dbh->quote($first) ); + + #exact + my $sql = scalar(keys %options) ? ' AND ' : ' WHERE '; + $sql .= " + ( ( LOWER(last) = $q_last AND LOWER(first) = $q_first ) + OR ( LOWER(ship_last) = $q_last AND LOWER(ship_first) = $q_first ) + )"; + + push @cust_main, qsearch( { + 'table' => 'cust_main', + 'hashref' => \%options, + 'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization + } ); + + # or it just be something that was typed in... (try that in a sec) + + } + my $q_value = dbh->quote($value); #exact my $sql = scalar(keys %options) ? ' AND ' : ' WHERE '; - $sql .= " ( LOWER(last) = $q_value OR LOWER(company) = $q_value"; - $sql .= " OR LOWER(ship_last) = $q_value OR LOWER(ship_company) = $q_value" - if defined dbdef->table('cust_main')->column('ship_last'); - $sql .= ' )'; - - push @cust_main, qsearch( 'cust_main', \%options, '', $sql ); + $sql .= " ( LOWER(last) = $q_value + OR LOWER(company) = $q_value + OR LOWER(ship_last) = $q_value + OR LOWER(ship_company) = $q_value + )"; + + push @cust_main, qsearch( { + 'table' => 'cust_main', + 'hashref' => \%options, + 'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization + } ); - unless ( @cust_main ) { #no exact match, trying substring/fuzzy + #always do substring & fuzzy, + #getting complains searches are not returning enough + #unless ( @cust_main ) { #no exact match, trying substring/fuzzy #still some false laziness w/ search/cust_main.cgi #substring - push @cust_main, qsearch( 'cust_main', - { 'last' => { 'op' => 'ILIKE', - 'value' => "%$q_value%" }, - %options, - } - ); - push @cust_main, qsearch( 'cust_main', - { 'ship_last' => { 'op' => 'ILIKE', - 'value' => "%$q_value%" }, - %options, - - } - ) - if defined dbdef->table('cust_main')->column('ship_last'); - - push @cust_main, qsearch( 'cust_main', - { 'company' => { 'op' => 'ILIKE', - 'value' => "%$q_value%" }, - %options, - } - ); - push @cust_main, qsearch( 'cust_main', - { 'ship_company' => { 'op' => 'ILIKE', - 'value' => "%$q_value%" }, - %options, - } - ) - if defined dbdef->table('cust_main')->column('ship_last'); - #fuzzy - push @cust_main, FS::cust_main->fuzzy_search( - { 'last' => $value }, - \%options, + my @hashrefs = ( + { 'company' => { op=>'ILIKE', value=>"%$value%" }, }, + { 'ship_company' => { op=>'ILIKE', value=>"%$value%" }, }, ); - push @cust_main, FS::cust_main->fuzzy_search( - { 'company' => $value }, - \%options, + + if ( $first && $last ) { + + push @hashrefs, + { 'first' => { op=>'ILIKE', value=>"%$first%" }, + 'last' => { op=>'ILIKE', value=>"%$last%" }, + }, + { 'ship_first' => { op=>'ILIKE', value=>"%$first%" }, + 'ship_last' => { op=>'ILIKE', value=>"%$last%" }, + }, + ; + + } else { + + push @hashrefs, + { 'last' => { op=>'ILIKE', value=>"%$value%" }, }, + { 'ship_last' => { op=>'ILIKE', value=>"%$value%" }, }, + ; + } + + foreach my $hashref ( @hashrefs ) { + + push @cust_main, qsearch( { + 'table' => 'cust_main', + 'hashref' => { %$hashref, + %options, + }, + 'extra_sql' => " AND $agentnums_sql", #agent virtualizaiton + } ); + + } + + #fuzzy + my @fuzopts = ( + \%options, #hashref + '', #select + " AND $agentnums_sql", #extra_sql #agent virtualization ); - } + if ( $first && $last ) { + push @cust_main, FS::cust_main->fuzzy_search( + { 'last' => $last, #fuzzy hashref + 'first' => $first }, # + @fuzopts + ); + } + foreach my $field ( 'last', 'company' ) { + push @cust_main, + FS::cust_main->fuzzy_search( { $field => $value }, @fuzopts ); + } + + #} + + #eliminate duplicates + my %saw = (); + @cust_main = grep { !$saw{$_->custnum}++ } @cust_main; } @@ -3795,10 +4339,12 @@ sub smart_search { =cut +use vars qw(@fuzzyfields); +@fuzzyfields = ( 'last', 'first', 'company' ); + 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; + rebuild_fuzzyfiles() if grep { ! -e "$dir/cust_main.$_" } @fuzzyfields } =item rebuild_fuzzyfiles @@ -3810,72 +4356,48 @@ sub rebuild_fuzzyfiles { use Fcntl qw(:flock); my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc; + mkdir $dir, 0700 unless -d $dir; - #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: $!"; + foreach my $fuzzy ( @fuzzyfields ) { - 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(LOCK,">>$dir/cust_main.$fuzzy") + or die "can't open $dir/cust_main.$fuzzy: $!"; + flock(LOCK,LOCK_EX) + or die "can't lock $dir/cust_main.$fuzzy: $!"; - 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: $!"; + open (CACHE,">$dir/cust_main.$fuzzy.tmp") + or die "can't open $dir/cust_main.$fuzzy.tmp: $!"; - rename "$dir/cust_main.company.tmp", "$dir/cust_main.company"; - close COMPANYLOCK; + foreach my $field ( $fuzzy, "ship_$fuzzy" ) { + my $sth = dbh->prepare("SELECT $field FROM cust_main". + " WHERE $field != '' AND $field IS NOT NULL"); + $sth->execute or die $sth->errstr; -} + while ( my $row = $sth->fetchrow_arrayref ) { + print CACHE $row->[0]. "\n"; + } -=item all_last + } -=cut + close CACHE or die "can't close $dir/cust_main.$fuzzy.tmp: $!"; + + rename "$dir/cust_main.$fuzzy.tmp", "$dir/cust_main.$fuzzy"; + close LOCK; + } -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 +=item all_X =cut -sub all_company { +sub all_X { + my( $self, $field ) = @_; 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; + open(CACHE,"<$dir/cust_main.$field") + or die "can't open $dir/cust_main.$field: $!"; + my @array = map { chomp; $_; } <CACHE>; + close CACHE; \@array; } @@ -3884,7 +4406,7 @@ sub all_company { =cut sub append_fuzzyfiles { - my( $last, $company ) = @_; + #my( $first, $last, $company ) = @_; &check_and_rebuild_fuzzyfiles; @@ -3892,33 +4414,23 @@ sub append_fuzzyfiles { my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc; - if ( $last ) { + foreach my $field (qw( first last company )) { + my $value = shift; - 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: $!"; + if ( $value ) { - print LAST "$last\n"; + open(CACHE,">>$dir/cust_main.$field") + or die "can't open $dir/cust_main.$field: $!"; + flock(CACHE,LOCK_EX) + or die "can't lock $dir/cust_main.$field: $!"; - flock(LAST,LOCK_UN) - or die "can't unlock $dir/cust_main.last: $!"; - close LAST; - } + print CACHE "$value\n"; - 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: $!"; + flock(CACHE,LOCK_UN) + or die "can't unlock $dir/cust_main.$field: $!"; + close CACHE; + } - close COMPANY; } 1; @@ -3933,12 +4445,34 @@ sub batch_import { #warn join('-',keys %$param); my $fh = $param->{filehandle}; my $agentnum = $param->{agentnum}; + my $refnum = $param->{refnum}; my $pkgpart = $param->{pkgpart}; - my @fields = @{$param->{fields}}; - eval "use Date::Parse;"; - die $@ if $@; + #my @fields = @{$param->{fields}}; + my $format = $param->{'format'}; + my @fields; + my $payby; + if ( $format eq 'simple' ) { + @fields = qw( cust_pkg.setup dayphone first last + address1 address2 city state zip comments ); + $payby = 'BILL'; + } elsif ( $format eq 'extended' ) { + @fields = qw( agent_custid refnum + last first address1 address2 city state zip country + daytime night + ship_last ship_first ship_address1 ship_address2 + ship_city ship_state ship_zip ship_country + payinfo paycvv paydate + invoicing_list + cust_pkg.pkgpart + svc_acct.username svc_acct._password + ); + $payby = 'BILL'; + } else { + die "unknown format $format"; + } + eval "use Text::CSV_XS;"; die $@ if $@; @@ -3976,51 +4510,111 @@ sub batch_import { agentnum => $agentnum, refnum => $refnum, country => $conf->config('countrydefault') || 'US', - payby => 'BILL', #default + payby => $payby, #default paydate => '12/2037', #default ); my $billtime = time; my %cust_pkg = ( pkgpart => $pkgpart ); + my %svc_acct = (); foreach my $field ( @fields ) { - if ( $field =~ /^cust_pkg\.(setup|bill|susp|expire|cancel)$/ ) { + + if ( $field =~ /^cust_pkg\.(pkgpart|setup|bill|susp|expire|cancel)$/ ) { + #$cust_pkg{$1} = str2time( shift @$columns ); - if ( $1 eq 'setup' ) { + if ( $1 eq 'pkgpart' ) { + $cust_pkg{$1} = shift @columns; + } elsif ( $1 eq 'setup' ) { $billtime = str2time(shift @columns); } else { $cust_pkg{$1} = str2time( shift @columns ); - } + } + + } elsif ( $field =~ /^svc_acct\.(username|_password)$/ ) { + + $svc_acct{$1} = shift @columns; + } else { + + #refnum interception + if ( $field eq 'refnum' && $columns[0] !~ /^\s*(\d+)\s*$/ ) { + + my $referral = $columns[0]; + my %hash = ( 'referral' => $referral, + 'agentnum' => $agentnum, + 'disabled' => '', + ); + + my $part_referral = qsearchs('part_referral', \%hash ) + || new FS::part_referral \%hash; + + unless ( $part_referral->refnum ) { + my $error = $part_referral->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "can't auto-insert advertising source: $referral: $error"; + } + } + + $columns[0] = $part_referral->refnum; + } + #$cust_main{$field} = shift @$columns; $cust_main{$field} = shift @columns; } } - my $cust_pkg = new FS::cust_pkg ( \%cust_pkg ) if $pkgpart; + $cust_main{'payby'} = 'CARD' if length($cust_main{'payinfo'}); + + my $invoicing_list = $cust_main{'invoicing_list'} + ? [ delete $cust_main{'invoicing_list'} ] + : []; + my $cust_main = new FS::cust_main ( \%cust_main ); + use Tie::RefHash; tie my %hash, 'Tie::RefHash'; #this part is important - $hash{$cust_pkg} = [] if $pkgpart; - my $error = $cust_main->insert( \%hash ); - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "can't insert customer for $line: $error"; + if ( $cust_pkg{'pkgpart'} ) { + my $cust_pkg = new FS::cust_pkg ( \%cust_pkg ); + + my @svc_acct = (); + if ( $svc_acct{'username'} ) { + my $part_pkg = $cust_pkg->part_pkg; + unless ( $part_pkg ) { + $dbh->rollback if $oldAutoCommit; + return "unknown pkgnum ". $cust_pkg{'pkgpart'}; + } + $svc_acct{svcpart} = $part_pkg->svcpart( 'svc_acct' ); + push @svc_acct, new FS::svc_acct ( \%svc_acct ) + } + + $hash{$cust_pkg} = \@svc_acct; } - #false laziness w/bill.cgi - $error = $cust_main->bill( 'time' => $billtime ); + my $error = $cust_main->insert( \%hash, $invoicing_list ); + if ( $error ) { $dbh->rollback if $oldAutoCommit; - return "can't bill customer for $line: $error"; + return "can't insert customer for $line: $error"; } - $cust_main->apply_payments; - $cust_main->apply_credits; + if ( $format eq 'simple' ) { + + #false laziness w/bill.cgi + $error = $cust_main->bill( 'time' => $billtime ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "can't bill customer for $line: $error"; + } + + $cust_main->apply_payments_and_credits; + + $error = $cust_main->collect(); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "can't collect customer for $line: $error"; + } - $error = $cust_main->collect(); - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "can't collect customer for $line: $error"; } $imported++; @@ -4044,8 +4638,6 @@ sub batch_charge { my $fh = $param->{filehandle}; my @fields = @{$param->{fields}}; - eval "use Date::Parse;"; - die $@ if $@; eval "use Text::CSV_XS;"; die $@ if $@; @@ -4119,6 +4711,94 @@ sub batch_charge { } +=item notify CUSTOMER_OBJECT TEMPLATE_NAME OPTIONS + +Sends a templated email notification to the customer (see L<Text::Template). + +OPTIONS is a hash and may include + +I<from> - the email sender (default is invoice_from) + +I<to> - comma-separated scalar or arrayref of recipients + (default is invoicing_list) + +I<subject> - The subject line of the sent email notification + (default is "Notice from company_name") + +I<extra_fields> - a hashref of name/value pairs which will be substituted + into the template + +The following variables are vavailable in the template. + +I<$first> - the customer first name +I<$last> - the customer last name +I<$company> - the customer company +I<$payby> - a description of the method of payment for the customer + # would be nice to use FS::payby::shortname +I<$payinfo> - the account information used to collect for this customer +I<$expdate> - the expiration of the customer payment in seconds from epoch + +=cut + +sub notify { + my ($customer, $template, %options) = @_; + + return unless $conf->exists($template); + + my $from = $conf->config('invoice_from') if $conf->exists('invoice_from'); + $from = $options{from} if exists($options{from}); + + my $to = join(',', $customer->invoicing_list_emailonly); + $to = $options{to} if exists($options{to}); + + my $subject = "Notice from " . $conf->config('company_name') + if $conf->exists('company_name'); + $subject = $options{subject} if exists($options{subject}); + + my $notify_template = new Text::Template (TYPE => 'ARRAY', + SOURCE => [ map "$_\n", + $conf->config($template)] + ) + or die "can't create new Text::Template object: Text::Template::ERROR"; + $notify_template->compile() + or die "can't compile template: Text::Template::ERROR"; + + my $paydate = $customer->paydate; + $FS::notify_template::_template::first = $customer->first; + $FS::notify_template::_template::last = $customer->last; + $FS::notify_template::_template::company = $customer->company; + $FS::notify_template::_template::payinfo = $customer->mask_payinfo; + my $payby = $customer->payby; + my ($payyear,$paymonth,$payday) = split (/-/,$paydate); + my $expire_time = timelocal(0,0,0,$payday,--$paymonth,$payyear); + + #credit cards expire at the end of the month/year of their exp date + if ($payby eq 'CARD' || $payby eq 'DCRD') { + $FS::notify_template::_template::payby = 'credit card'; + ($paymonth < 11) ? $paymonth++ : ($paymonth=0, $payyear++); + $expire_time = timelocal(0,0,0,$payday,$paymonth,$payyear); + $expire_time--; + }elsif ($payby eq 'COMP') { + $FS::notify_template::_template::payby = 'complimentary account'; + }else{ + $FS::notify_template::_template::payby = 'current method'; + } + $FS::notify_template::_template::expdate = $expire_time; + + for (keys %{$options{extra_fields}}){ + no strict "refs"; + ${"FS::notify_template::_template::$_"} = $options{extra_fields}->{$_}; + } + + send_email(from => $from, + to => $to, + subject => $subject, + body => $notify_template->fill_in( PACKAGE => + 'FS::notify_template::_template' ), + ); + +} + =back =head1 BUGS @@ -4138,6 +4818,8 @@ No multiple currency support (probably a larger project than just this module). payinfo_masked false laziness with cust_pay.pm and cust_refund.pm +Birthdates rely on negative epoch values. + =head1 SEE ALSO L<FS::Record>, L<FS::cust_pkg>, L<FS::cust_bill>, L<FS::cust_credit> diff --git a/FS/FS/cust_main_Mixin.pm b/FS/FS/cust_main_Mixin.pm index a114c5a8a..ced0a1f55 100644 --- a/FS/FS/cust_main_Mixin.pm +++ b/FS/FS/cust_main_Mixin.pm @@ -1,8 +1,12 @@ package FS::cust_main_Mixin; use strict; +use vars qw( $DEBUG ); +use FS::UID qw(dbh); use FS::cust_main; +$DEBUG = 0; + =head1 NAME FS::cust_main_Mixin - Mixin class for records that contain fields from cust_main @@ -89,6 +93,168 @@ sub ship_contact { : $self->cust_unlinked_msg; } +=item country_full + +Given an object that contains fields from cust_main (say, from a JOINed +search; see httemplate/search/ for examples), returns the equivalent of the +FS::cust_main I<country_full> method, or "(unlinked)" if this object is not +linked to a customer. + +=cut + +sub country_full { + my $self = shift; + $self->cust_linked + ? FS::cust_main::country_full($self) + : $self->cust_unlinked_msg; +} + +=item invoicing_list_emailonly + +Given an object that contains fields from cust_main (say, from a JOINed +search; see httemplate/search/ for examples), returns the equivalent of the +FS::cust_main I<invoicing_list_emailonly> method, or "(unlinked)" if this +object is not linked to a customer. + +=cut + +sub invoicing_list_emailonly { + my $self = shift; + warn "invoicing_list_email only called on $self, ". + "custnum ". $self->custnum. "\n" + if $DEBUG; + $self->cust_linked + ? FS::cust_main::invoicing_list_emailonly($self) + : $self->cust_unlinked_msg; +} + +=item invoicing_list_emailonly_scalar + +Given an object that contains fields from cust_main (say, from a JOINed +search; see httemplate/search/ for examples), returns the equivalent of the +FS::cust_main I<invoicing_list_emailonly_scalar> method, or "(unlinked)" if +this object is not linked to a customer. + +=cut + +sub invoicing_list_emailonly_scalar { + my $self = shift; + warn "invoicing_list_emailonly called on $self, ". + "custnum ". $self->custnum. "\n" + if $DEBUG; + $self->cust_linked + ? FS::cust_main::invoicing_list_emailonly_scalar($self) + : $self->cust_unlinked_msg; +} + +=item invoicing_list + +Given an object that contains fields from cust_main (say, from a JOINed +search; see httemplate/search/ for examples), returns the equivalent of the +FS::cust_main I<invoicing_list> method, or "(unlinked)" if this object is not +linked to a customer. + +Note: this method is read-only. + +=cut + +#read-only +sub invoicing_list { + my $self = shift; + $self->cust_linked + ? FS::cust_main::invoicing_list($self) + : (); +} + +=item status + +Given an object that contains fields from cust_main (say, from a JOINed +search; see httemplate/search/ for examples), returns the equivalent of the +FS::cust_main I<status> method, or "(unlinked)" if this object is not linked to +a customer. + +=cut + +sub cust_status { + my $self = shift; + return $self->cust_unlinked_msg unless $self->cust_linked; + + #FS::cust_main::status($self) + #false laziness w/actual cust_main::status + # (make sure FS::cust_main methods are called) + for my $status (qw( prospect active inactive suspended cancelled )) { + my $method = $status.'_sql'; + my $sql = FS::cust_main->$method();; + my $numnum = ( $sql =~ s/cust_main\.custnum/?/g ); + my $sth = dbh->prepare("SELECT $sql") or die dbh->errstr; + $sth->execute( ($self->custnum) x $numnum ) + or die "Error executing 'SELECT $sql': ". $sth->errstr; + return $status if $sth->fetchrow_arrayref->[0]; + } +} + +=item ucfirst_cust_status + +Given an object that contains fields from cust_main (say, from a JOINed +search; see httemplate/search/ for examples), returns the equivalent of the +FS::cust_main I<ucfirst_status> method, or "(unlinked)" if this object is not +linked to a customer. + +=cut + +sub ucfirst_cust_status { + my $self = shift; + $self->cust_linked + ? ucfirst( $self->cust_status(@_) ) + : $self->cust_unlinked_msg; +} + +=item cust_statuscolor + +Given an object that contains fields from cust_main (say, from a JOINed +search; see httemplate/search/ for examples), returns the equivalent of the +FS::cust_main I<statuscol> method, or "000000" if this object is not linked to +a customer. + +=cut + +sub cust_statuscolor { + my $self = shift; + + $self->cust_linked + ? FS::cust_main::cust_statuscolor($self) + : '000000'; +} + +=item prospect_sql + +=item active_sql + +=item inactive_sql + +=item suspended_sql + +=item cancelled_sql + +Given an object that contains fields from cust_main (say, from a JOINed +search; see httemplate/search/ for examples), returns the equivalent of the +corresponding FS::cust_main method, or "0" if this object is not linked to +a customer. + +=cut + +foreach my $sub (qw( prospect active inactive suspended cancelled )) { + eval " + sub ${sub}_sql { + my \$self = shift; + \$self->cust_linked + ? FS::cust_main::${sub}_sql(\$self) + : '0'; + } + "; + die $@ if $@; +} + =back =head1 BUGS diff --git a/FS/FS/cust_main_invoice.pm b/FS/FS/cust_main_invoice.pm index 48f47e0cd..71029d096 100644 --- a/FS/FS/cust_main_invoice.pm +++ b/FS/FS/cust_main_invoice.pm @@ -91,7 +91,7 @@ sub replace { 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. +and replace methods. =cut diff --git a/FS/FS/cust_main_note.pm b/FS/FS/cust_main_note.pm new file mode 100644 index 000000000..4732d12ce --- /dev/null +++ b/FS/FS/cust_main_note.pm @@ -0,0 +1,131 @@ +package FS::cust_main_note; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::cust_main_note - Object methods for cust_main_note records + +=head1 SYNOPSIS + + use FS::cust_main_note; + + $record = new FS::cust_main_note \%hash; + $record = new FS::cust_main_note { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::cust_main_note object represents a note attachted to a customer. +FS::cust_main_note inherits from FS::Record. The following fields are +currently supported: + +=over 4 + +=item notenum - primary key + +=item custnum - + +=item _date - + +=item otaker - + +=item comments - + + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new customer note. To add the note 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_main_note'; } + +=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('notenum') + || $self->ut_number('custnum') + || $self->ut_numbern('_date') + || $self->ut_text('otaker') + || $self->ut_anything('comments') + ; + return $error if $error; + + $self->SUPER::check; +} + +=back + +=head1 BUGS + +Lurking in the cracks. + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/cust_pay.pm b/FS/FS/cust_pay.pm index f057d2faf..30333e0c4 100644 --- a/FS/FS/cust_pay.pm +++ b/FS/FS/cust_pay.pm @@ -1,20 +1,21 @@ package FS::cust_pay; use strict; -use vars qw( @ISA $conf $unsuspendauto $ignore_noapply ); +use vars qw( @ISA $conf $unsuspendauto $ignore_noapply @encrypted_fields ); use Date::Format; use Business::CreditCard; use Text::Template; use FS::Misc qw(send_email); use FS::Record qw( dbh qsearch qsearchs ); use FS::cust_main_Mixin; +use FS::payinfo_Mixin; use FS::cust_bill; use FS::cust_bill_pay; use FS::cust_pay_refund; use FS::cust_main; use FS::cust_pay_void; -@ISA = qw( FS::cust_main_Mixin FS::Record ); +@ISA = qw(FS::Record FS::cust_main_Mixin FS::payinfo_Mixin ); $ignore_noapply = 0; @@ -24,6 +25,8 @@ FS::UID->install_callback( sub { $unsuspendauto = $conf->exists('unsuspendauto'); } ); +@encrypted_fields = ('payinfo'); + =head1 NAME FS::cust_pay - Object methods for cust_pay objects @@ -60,12 +63,11 @@ currently supported: =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), `CHEK' (electronic check/ACH), -`LECB' (phone bill billing), `BILL' (billing), `PREP` (prepaid card), -`CASH' (cash), `WEST' (Western Union), `MCRD' (Manual credit card), or -`COMP' (free) +=item payby - Payment Type (See L<FS::payinfo_Mixin> for valid payby values) + +=item payinfo - Payment Information (See L<FS::payinfo_Mixin> for data format) -=item payinfo - card number, check #, or comp issuer (4-8 lowercase alphanumerics; think username), respectively +=item paymask - Masked payinfo (See L<FS::payinfo_Mixin> for how this works) =item paybatch - text field for tracking card processing @@ -97,12 +99,15 @@ 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. +will be created. In this case, custnum is optional. An hash of optional +arguments may be passed. Currently "manual" is supported. If true, a +payment receipt is sent instead of a statement when 'payment_receipt_email' +configuration option is set. =cut sub insert { - my $self = shift; + my ($self, %options) = @_; local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; @@ -115,8 +120,9 @@ sub insert { local $FS::UID::AutoCommit = 0; my $dbh = dbh; + my $cust_bill; if ( $self->invnum ) { - my $cust_bill = qsearchs('cust_bill', { 'invnum' => $self->invnum } ) + $cust_bill = qsearchs('cust_bill', { 'invnum' => $self->invnum } ) or do { $dbh->rollback if $oldAutoCommit; return "Unknown cust_bill.invnum: ". $self->invnum; @@ -187,27 +193,36 @@ sub insert { && grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list ) { - my $receipt_template = new Text::Template ( - TYPE => 'ARRAY', - SOURCE => [ map "$_\n", $conf->config('payment_receipt_email') ], - ) or do { - warn "can't create payment receipt template: $Text::Template::ERROR"; - return ''; - }; + $cust_bill ||= ($cust_main->cust_bill)[-1]; #rather inefficient though? + + my $error; + if ( ( exists($options{'manual'}) && $options{'manual'} ) + || ! $conf->exists('invoice_html_statement') + || ! $cust_bill + ) { - my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list; + my $receipt_template = new Text::Template ( + TYPE => 'ARRAY', + SOURCE => [ map "$_\n", $conf->config('payment_receipt_email') ], + ) or do { + warn "can't create payment receipt template: $Text::Template::ERROR"; + return ''; + }; - my $payby = $self->payby; - my $payinfo = $self->payinfo; - $payby =~ s/^BILL$/Check/ if $payinfo; - $payinfo = $self->payinfo_masked if $payby eq 'CARD' || $payby eq 'CHEK'; - $payby =~ s/^CHEK$/Electronic check/; + my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } + $cust_main->invoicing_list; - my $error = send_email( - 'from' => $conf->config('invoice_from'), #??? well as good as any - 'to' => \@invoicing_list, - 'subject' => 'Payment receipt', - 'body' => [ $receipt_template->fill_in( HASH => { + my $payby = $self->payby; + my $payinfo = $self->payinfo; + $payby =~ s/^BILL$/Check/ if $payinfo; + $payinfo = $self->paymask if $payby eq 'CARD' || $payby eq 'CHEK'; + $payby =~ s/^CHEK$/Electronic check/; + + $error = send_email( + 'from' => $conf->config('invoice_from'), #??? well as good as any + 'to' => \@invoicing_list, + 'subject' => 'Payment receipt', + 'body' => [ $receipt_template->fill_in( HASH => { 'date' => time2str("%a %B %o, %Y", $self->_date), 'name' => $cust_main->name, 'paynum' => $self->paynum, @@ -215,10 +230,24 @@ sub insert { 'payby' => ucfirst(lc($payby)), 'payinfo' => $payinfo, 'balance' => $cust_main->balance, - } ) ], - ); + } ) ], + ); + + } else { + + my $queue = new FS::queue { + 'paynum' => $self->paynum, + 'job' => 'FS::cust_bill::queueable_email', + }; + $error = $queue->insert( + 'invnum' => $cust_bill->invnum, + 'template' => 'statement', + ); + + } + if ( $error ) { - warn "can't send payment receipt: $error"; + warn "can't send payment receipt/statement: $error"; } } @@ -272,12 +301,14 @@ sub void { =item delete -Deletes this payment and all associated applications (see L<FS::cust_bill_pay>), -unless the closed flag is set. In most cases, you want to use the void -method instead to leave a record of the deleted payment. +Unless the closed flag is set, deletes this payment and all associated +applications (see L<FS::cust_bill_pay> and L<FS::cust_pay_refund>). In most +cases, you want to use the void method instead to leave a record of the +deleted payment. =cut +# very similar to FS::cust_credit::delete sub delete { my $self = shift; return "Can't delete closed payment" if $self->closed =~ /^Y/i; @@ -325,7 +356,7 @@ sub delete { 'paid: $'. sprintf("%.2f", $self->paid). "\n", 'date: '. time2str("%a %b %e %T %Y", $self->_date). "\n", 'payby: '. $self->payby. "\n", - 'payinfo: '. $self->payinfo. "\n", + 'payinfo: '. $self->paymask. "\n", 'paybatch: '. $self->paybatch. "\n", ], ); @@ -345,7 +376,16 @@ sub delete { =item replace OLD_RECORD -You probably shouldn't modify payments... +You can, but probably shouldn't modify payments... + +=cut + +sub replace { + #return "Can't modify payment!" + my $self = shift; + return "Can't modify closed payment" if $self->closed =~ /^Y/i; + $self->SUPER::replace(@_); +} =item check @@ -364,6 +404,7 @@ sub check { || $self->ut_numbern('_date') || $self->ut_textn('paybatch') || $self->ut_enum('closed', [ '', 'Y' ]) + || $self->payinfo_check() ; return $error if $error; @@ -375,30 +416,6 @@ sub check { $self->_date(time) unless $self->_date; - $self->payby =~ /^(CARD|CHEK|LECB|BILL|COMP|PREP|CASH|WEST|MCRD)$/ - 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; - } - $self->SUPER::check; } @@ -438,7 +455,7 @@ sub batch_insert { my $errors = 0; my @errors = map { - my $error = $_->insert; + my $error = $_->insert( 'manual' => 1 ); if ( $error ) { $errors++; } else { @@ -529,33 +546,11 @@ sub cust_main { qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); } -=item payinfo_masked - -Returns a "masked" payinfo field with all but the last four characters replaced -by 'x'es. Useful for displaying credit cards. - -=cut - -sub payinfo_masked { - my $self = shift; - #some false laziness w/cust_main::paymask - if ( $self->payby eq 'CARD' ) { - my $payinfo = $self->payinfo; - 'x'x(length($payinfo)-4). substr($payinfo,(length($payinfo)-4)); - } elsif ( $self->payby eq 'CHEK' ) { - my( $account, $aba ) = split('@', $self->payinfo ); - 'x'x(length($account)-2). substr($account,(length($account)-2)). "@". $aba; - } else { - $self->payinfo; - } -} - =back =head1 BUGS -Delete and replace methods. payinfo_masked false laziness with cust_main.pm -and cust_refund.pm +Delete and replace methods. =head1 SEE ALSO diff --git a/FS/FS/cust_pay_batch.pm b/FS/FS/cust_pay_batch.pm index 8059f1ca2..573f06f3a 100644 --- a/FS/FS/cust_pay_batch.pm +++ b/FS/FS/cust_pay_batch.pm @@ -1,11 +1,17 @@ package FS::cust_pay_batch; use strict; -use vars qw( @ISA ); -use FS::Record qw(dbh qsearchs); -use Business::CreditCard; +use vars qw( @ISA $DEBUG ); +use FS::Record qw(dbh qsearch qsearchs); +use FS::payinfo_Mixin; +use Business::CreditCard 0.28; -@ISA = qw( FS::Record ); +@ISA = qw( FS::Record FS::payinfo_Mixin ); + +# 1 is mostly method/subroutine entry and options +# 2 traces progress of some operations +# 3 is even more information including possibly sensitive data +$DEBUG = 0; =head1 NAME @@ -26,6 +32,8 @@ FS::cust_pay_batch - Object methods for batch cards $error = $record->check; + $error = $record->retriable; + =head1 DESCRIPTION An FS::cust_pay_batch object represents a credit card transaction ready to be @@ -37,7 +45,11 @@ following fields are currently supported: =item paybatchnum - primary key (automatically assigned) -=item cardnum +=item batchnum - indentifies group in batch + +=item payby - CARD/CHEK/LECB/BILL/COMP + +=item payinfo =item exp - card expiration @@ -65,6 +77,8 @@ following fields are currently supported: =item country +=item status + =back =head1 METHODS @@ -94,22 +108,14 @@ 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!"; -} +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 transaction. If there is an error, returns the error, otherwise returns false. Called by the insert -and repalce methods. +and replace methods. =cut @@ -118,8 +124,7 @@ sub check { my $error = $self->ut_numbern('paybatchnum') - || $self->ut_numbern('trancode') #depriciated - || $self->ut_number('cardnum') + || $self->ut_numbern('trancode') #deprecated || $self->ut_money('amount') || $self->ut_number('invnum') || $self->ut_number('custnum') @@ -137,17 +142,12 @@ sub check { $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"; + $error = $self->payinfo_check(); + return $error if $error; if ( $self->exp eq '' ) { - return "Expriation date required"; #unless + return "Expiration date required" + unless $self->payby =~ /^(CHEK|DCHK|LECB|WEST)$/; $self->exp(''); } else { if ( $self->exp =~ /^(\d{4})[\/\-](\d{1,2})[\/\-](\d{1,2})$/ ) { @@ -173,15 +173,16 @@ sub check { $self->payname($1); } - #$self->zip =~ /^\s*(\w[\w\-\s]{3,8}\w)\s*$/ - # or return "Illegal zip: ". $self->zip; - #$self->zip($1); + #we have lots of old zips in there... don't hork up batch results cause of em + $self->zip =~ /^\s*(\w[\w\-\s]{2,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; + #$error = $self->ut_zip('zip', $self->country); + #return $error if $error; #check invnum, custnum, ? @@ -200,101 +201,22 @@ sub cust_main { qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); } -=back - -=head1 SUBROUTINES +=item retriable -=over 4 +Marks the corresponding event (see L<FS::cust_bill_event>) for this batched +credit card payment as retriable. Useful if the corresponding financial +institution account was declined for temporary reasons and/or a manual +retry is desired. -=item import_results +Implementation details: For the named customer's invoice, changes the +statustext of the 'done' (without statustext) event to 'retriable.' =cut -sub import_results { - use Time::Local; - use FS::cust_pay; - eval "use Text::CSV_XS;"; - die $@ if $@; -# - my $param = shift; - my $fh = $param->{'filehandle'}; - my $format = $param->{'format'}; - my $paybatch = $param->{'paybatch'}; - - my @fields; - my $end_condition; - my $end_hook; - my $hook; - my $approved_condition; - my $declined_condition; - - if ( $format eq 'csv-td_canada_trust-merchant_pc_batch' ) { - - @fields = ( - 'paybatchnum', # Reference#: Invoice number of the transaction - 'paid', # Amount: Amount of the transaction. Dollars and cents - # with no decimal entered. - '', # Card Type: 0 - MCrd, 1 - Visa, 2 - AMEX, 3 - Discover, - # 4 - Insignia, 5 - Diners/EnRoute, 6 - JCB - '_date', # Transaction Date: Date the Transaction was processed - 'time', # Transaction Time: Time the transaction was processed - 'payinfo', # Card Number: Card number for the transaction - '', # Expiry Date: Expiry date of the card - '', # Auth#: Authorization number entered for force post - # transaction - 'type', # Transaction Type: 0 - purchase, 40 - refund, - # 20 - force post - 'result', # Processing Result: 3 - Approval, - # 4 - Declined/Amount over limit, - # 5 - Invalid/Expired/stolen card, - # 6 - Comm Error - '', # Terminal ID: Terminal ID used to process the transaction - ); - - $end_condition = sub { - my $hash = shift; - $hash->{'type'} eq '0BC'; - }; - - $end_hook = sub { - my( $hash, $total) = @_; - $total = sprintf("%.2f", $total); - my $batch_total = sprintf("%.2f", $hash->{'paybatchnum'} / 100 ); - return "Our total $total does not match bank total $batch_total!" - if $total != $batch_total; - ''; - }; - - $hook = sub { - my $hash = shift; - $hash->{'paid'} = sprintf("%.2f", $hash->{'paid'} / 100 ); - $hash->{'_date'} = timelocal( substr($hash->{'time'}, 4, 2), - substr($hash->{'time'}, 2, 2), - substr($hash->{'time'}, 0, 2), - substr($hash->{'_date'}, 6, 2), - substr($hash->{'_date'}, 4, 2)-1, - substr($hash->{'_date'}, 0, 4)-1900, ); - }; - - $approved_condition = sub { - my $hash = shift; - $hash->{'type'} eq '0' && $hash->{'result'} == 3; - }; - - $declined_condition = sub { - my $hash = shift; - $hash->{'type'} eq '0' && ( $hash->{'result'} == 4 - || $hash->{'result'} == 5 ); - }; - - - } else { - return "Unknown format $format"; - } - - my $csv = new Text::CSV_XS; +sub retriable { + my $self = shift; - local $SIG{HUP} = 'IGNORE'; + local $SIG{HUP} = 'IGNORE'; #Hmm local $SIG{INT} = 'IGNORE'; local $SIG{QUIT} = 'IGNORE'; local $SIG{TERM} = 'IGNORE'; @@ -305,79 +227,26 @@ sub import_results { local $FS::UID::AutoCommit = 0; my $dbh = dbh; - my $total = 0; - my $line; - while ( defined($line=<$fh>) ) { - - next if $line =~ /^\s*$/; #skip blank lines - - $csv->parse($line) or do { - $dbh->rollback if $oldAutoCommit; - return "can't parse: ". $csv->error_input(); - }; - - my @values = $csv->fields(); - my %hash; - foreach my $field ( @fields ) { - my $value = shift @values; - next unless $field; - $hash{$field} = $value; - } - - if ( &{$end_condition}(\%hash) ) { - my $error = &{$end_hook}(\%hash, $total); - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return $error; - } - last; - } - - my $cust_pay_batch = - qsearchs('cust_pay_batch', { 'paybatchnum' => $hash{'paybatchnum'} } ); - unless ( $cust_pay_batch ) { - $dbh->rollback if $oldAutoCommit; - return "unknown paybatchnum $hash{'paybatchnum'}\n"; - } - my $custnum = $cust_pay_batch->custnum, - - my $error = $cust_pay_batch->delete; - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "error removing paybatchnum $hash{'paybatchnum'}: $error\n"; - } - - &{$hook}(\%hash); - - if ( &{$approved_condition}(\%hash) ) { - - my $cust_pay = new FS::cust_pay ( { - 'custnum' => $custnum, - 'payby' => 'CARD', - 'paybatch' => $paybatch, - map { $_ => $hash{$_} } (qw( paid _date payinfo )), - } ); - $error = $cust_pay->insert; - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "error adding payment paybatchnum $hash{'paybatchnum'}: $error\n"; - } - $total += $hash{'paid'}; - - $cust_pay->cust_main->apply_payments; - - } elsif ( &{$declined_condition}(\%hash) ) { - - #this should be configurable... if anybody else ever uses batches - $cust_pay_batch->cust_main->suspend; - - } - + my $cust_bill = qsearchs('cust_bill', { 'invnum' => $self->invnum } ) + or return "event $self->eventnum references nonexistant invoice $self->invnum"; + + warn "cust_pay_batch->retriable working with self of " . $self->paybatchnum . " and invnum of " . $self->invnum; + my @cust_bill_event = + sort { $a->part_bill_event->seconds <=> $b->part_bill_event->seconds } + grep { + $_->part_bill_event->eventcode =~ /\$cust_bill->batch_card/ + && $_->status eq 'done' + && ! $_->statustext + } + $cust_bill->cust_bill_event; + # complain loudly if scalar(@cust_bill_event) > 1 ? + my $error = $cust_bill_event[0]->retriable; + if ($error ) { + # gah, even with transactions. + $dbh->commit if $oldAutoCommit; #well. + return "error marking invoice event retriable: $error"; } - - $dbh->commit or die $dbh->errstr if $oldAutoCommit; ''; - } =back diff --git a/FS/FS/cust_pay_refund.pm b/FS/FS/cust_pay_refund.pm index 15e0e533a..cb9dbcef2 100644 --- a/FS/FS/cust_pay_refund.pm +++ b/FS/FS/cust_pay_refund.pm @@ -73,15 +73,26 @@ sub table { 'cust_pay_refund'; } Adds this cust_pay_refund to the database. If there is an error, returns the error, otherwise returns false. +=cut + +sub insert { + my $self = shift; + return "Can't apply refund to closed payment" + if $self->cust_pay->closed =~ /^Y/i; + return "Can't apply payment to closed refund" + if $self->cust_refund->closed =~ /^Y/i; + $self->SUPER::insert(@_); +} + =item delete =cut sub delete { my $self = shift; - return "Can't apply refund to closed payment" + return "Can't remove refund from closed payment" if $self->cust_pay->closed =~ /^Y/i; - return "Can't apply closed refund" + return "Can't remove payment from closed refund" if $self->cust_refund->closed =~ /^Y/i; $self->SUPER::delete(@_); } diff --git a/FS/FS/cust_pay_void.pm b/FS/FS/cust_pay_void.pm index 946d69fe1..de05f710b 100644 --- a/FS/FS/cust_pay_void.pm +++ b/FS/FS/cust_pay_void.pm @@ -1,6 +1,6 @@ package FS::cust_pay_void; use strict; -use vars qw( @ISA ); +use vars qw( @ISA @encrypted_fields ); use Business::CreditCard; use FS::UID qw(getotaker); use FS::Record qw(qsearchs dbh fields); # qsearch ); @@ -10,7 +10,9 @@ use FS::cust_pay; #use FS::cust_pay_refund; #use FS::cust_main; -@ISA = qw( FS::Record ); +@ISA = qw( FS::Record FS::payinfo_Mixin ); + +@encrypted_fields = ('payinfo'); =head1 NAME @@ -207,19 +209,6 @@ sub cust_main { qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); } -=item payinfo_masked - -Returns a "masked" payinfo field with all but the last four characters replaced -by 'x'es. Useful for displaying credit cards. - -=cut - -sub payinfo_masked { - my $self = shift; - my $payinfo = $self->payinfo; - 'x'x(length($payinfo)-4). substr($payinfo,(length($payinfo)-4)); -} - =back =head1 BUGS diff --git a/FS/FS/cust_pkg.pm b/FS/FS/cust_pkg.pm index 783cc73a3..b2ef2a259 100644 --- a/FS/FS/cust_pkg.pm +++ b/FS/FS/cust_pkg.pm @@ -1,7 +1,9 @@ package FS::cust_pkg; use strict; -use vars qw(@ISA $disable_agentcheck @SVCDB_CANCEL_SEQ $DEBUG); +use vars qw(@ISA $disable_agentcheck $DEBUG); +use List::Util qw(max); +use Tie::IxHash; use FS::UID qw( getotaker dbh ); use FS::Misc qw( send_email ); use FS::Record qw( qsearch qsearchs ); @@ -14,6 +16,9 @@ use FS::pkg_svc; use FS::cust_bill_pkg; use FS::h_cust_svc; use FS::reg_code; +use FS::part_svc; +use FS::cust_pkg_reason; +use FS::reason; # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend, # setup } @@ -26,20 +31,12 @@ use FS::svc_forward; # for sending cancel emails in sub cancel use FS::Conf; -@ISA = qw( FS::cust_main_Mixin FS::Record ); +@ISA = qw( FS::cust_main_Mixin FS::option_Common FS::Record ); $DEBUG = 0; $disable_agentcheck = 0; -# The order in which to unprovision services. -@SVCDB_CANCEL_SEQ = qw( svc_external - svc_www - svc_forward - svc_acct - svc_domain - svc_broadband ); - sub _cache { my $self = shift; my ( $hashref, $cache ) = @_; @@ -178,7 +175,7 @@ sub insert { local $FS::UID::AutoCommit = 0; my $dbh = dbh; - my $error = $self->SUPER::insert; + my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ()); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; @@ -269,8 +266,12 @@ Calls =cut sub replace { - my( $new, $old ) = ( shift, shift ); + my( $new, $old, %options ) = @_; + # We absolutely have to have an old vs. new record to make this work. + if (!defined($old)) { + $old = qsearchs( 'cust_pkg', { 'pkgnum' => $new->pkgnum } ); + } #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart; return "Can't change otaker!" if $old->otaker ne $new->otaker; @@ -294,6 +295,16 @@ sub replace { local $FS::UID::AutoCommit = 0; my $dbh = dbh; + if ($options{'reason'} && $new->expire && $old->expire ne $new->expire) { + my $error = $new->insert_reason( 'reason' => $options{'reason'}, + 'date' => $new->expire, + ); + if ( $error ) { + dbh->rollback if $oldAutoCommit; + return "Error inserting cust_pkg_reason: $error"; + } + } + #save off and freeze RADIUS attributes for any associated svc_acct records my @svc_acct = (); if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) { @@ -308,7 +319,9 @@ sub replace { } - my $error = $new->SUPER::replace($old); + my $error = $new->SUPER::replace($old, + $options{options} ? ${options{options}} : () + ); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; @@ -430,21 +443,28 @@ sub cancel { local $FS::UID::AutoCommit = 0; my $dbh = dbh; + if ($options{'reason'}) { + $error = $self->insert_reason( 'reason' => $options{'reason'} ); + if ( $error ) { + dbh->rollback if $oldAutoCommit; + return "Error inserting cust_pkg_reason: $error"; + } + } + my %svc; foreach my $cust_svc ( - qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) + #schwartz + map { $_->[0] } + sort { $a->[1] <=> $b->[1] } + map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; } + qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ) { - push @{ $svc{$cust_svc->part_svc->svcdb} }, $cust_svc; - } - foreach my $svcdb (@SVCDB_CANCEL_SEQ) { - foreach my $cust_svc (@{ $svc{$svcdb} }) { - my $error = $cust_svc->cancel; + my $error = $cust_svc->cancel; - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "Error cancelling cust_svc: $error"; - } + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Error cancelling cust_svc: $error"; } } @@ -466,7 +486,7 @@ sub cancel { my %hash = $self->hash; $hash{'cancel'} = time; my $new = new FS::cust_pkg ( \%hash ); - $error = $new->replace($self); + $error = $new->replace( $self, options => { $self->options } ); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; @@ -502,7 +522,7 @@ If there is an error, returns the error, otherwise returns false. =cut sub suspend { - my $self = shift; + my( $self, %options ) = @_; my $error ; local $SIG{HUP} = 'IGNORE'; @@ -516,6 +536,14 @@ sub suspend { local $FS::UID::AutoCommit = 0; my $dbh = dbh; + if ($options{'reason'}) { + $error = $self->insert_reason( 'reason' => $options{'reason'} ); + if ( $error ) { + dbh->rollback if $oldAutoCommit; + return "Error inserting cust_pkg_reason: $error"; + } + } + foreach my $cust_svc ( qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ) { @@ -543,7 +571,7 @@ sub suspend { my %hash = $self->hash; $hash{'susp'} = time; my $new = new FS::cust_pkg ( \%hash ); - $error = $new->replace($self); + $error = $new->replace( $self, options => { $self->options } ); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; @@ -555,18 +583,27 @@ sub suspend { ''; #no errors } -=item unsuspend +=item unsuspend [ OPTION => VALUE ... ] 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). +Available options are: I<adjust_next_bill>. + +I<adjust_next_bill> can be set true to adjust the next bill date forward by +the amount of time the account was inactive. This was set true by default +since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be +explicitly requested. Price plans for which this makes sense (anniversary-date +based than prorate or subscription) could have an option to enable this +behaviour? + If there is an error, returns the error, otherwise returns false. =cut sub unsuspend { - my $self = shift; - my($error); + my( $self, %opt ) = @_; + my $error; local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; @@ -605,11 +642,17 @@ sub unsuspend { unless ( ! $self->getfield('susp') ) { my %hash = $self->hash; my $inactive = time - $hash{'susp'}; - $hash{'susp'} = ''; + + my $conf = new FS::Conf; + $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive - if $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} ); + if ( $opt{'adjust_next_bill'} + || $conf->config('unsuspend-always_adjust_next_bill_date') ) + && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} ); + + $hash{'susp'} = ''; my $new = new FS::cust_pkg ( \%hash ); - $error = $new->replace($self); + $error = $new->replace( $self, options => { $self->options } ); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; @@ -639,6 +682,23 @@ sub last_bill { $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0; } +=item last_reason + +Returns the most recent FS::reason associated with the package. + +=cut + +sub last_reason { + my $self = shift; + my $cust_pkg_reason = qsearchs( { + 'table' => 'cust_pkg_reason', + 'hashref' => { 'pkgnum' => $self->pkgnum, }, + 'extra_sql'=> 'ORDER BY date DESC LIMIT 1', + } ); + qsearchs ( 'reason', { 'reasonnum' => $cust_pkg_reason->reasonnum } ) + if $cust_pkg_reason; +} + =item part_pkg Returns the definition for this billing item, as an FS::part_pkg object (see @@ -702,6 +762,17 @@ sub calc_cancel { $self->part_pkg->calc_cancel($self, @_); } +=item cust_bill_pkg + +Returns any invoice line items for this package (see L<FS::cust_bill_pkg>). + +=cut + +sub cust_bill_pkg { + my $self = shift; + qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } ); +} + =item cust_svc [ SVCPART ] Returns the services for this package, as FS::cust_svc objects (see @@ -783,7 +854,7 @@ sub num_cust_svc { =item available_part_svc -Returns a list FS::part_svc objects representing services included in this +Returns a list of FS::part_svc objects representing services included in this package but not yet provisioned. Each FS::part_svc object also has an extra field, I<num_avail>, which specifies the number of available services. @@ -801,6 +872,87 @@ sub available_part_svc { $self->part_pkg->pkg_svc; } +=item + +Returns a list of FS::part_svc objects representing provisioned and available +services included in this package. Each FS::part_svc object also has the +following extra fields: + +=over 4 + +=item num_cust_svc (count) + +=item num_avail (quantity - count) + +=item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects + +svcnum +label -> ($cust_svc->label)[1] + +=back + +=cut + +sub part_svc { + my $self = shift; + + #XXX some sort of sort order besides numeric by svcpart... + my @part_svc = sort { $a->svcpart <=> $b->svcpart } map { + my $pkg_svc = $_; + my $part_svc = $pkg_svc->part_svc; + my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart); + $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil + $part_svc->{'Hash'}{'num_avail'} = + max( 0, $pkg_svc->quantity - $num_cust_svc ); + $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ]; + $part_svc; + } $self->part_pkg->pkg_svc; + + #extras + push @part_svc, map { + my $part_svc = $_; + my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart); + $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail + $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ? + $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ]; + $part_svc; + } $self->extra_part_svc; + + @part_svc; + +} + +=item extra_part_svc + +Returns a list of FS::part_svc objects corresponding to services in this +package which are still provisioned but not (any longer) available in the +package definition. + +=cut + +sub extra_part_svc { + my $self = shift; + + my $pkgnum = $self->pkgnum; + my $pkgpart = $self->pkgpart; + + qsearch( { + 'table' => 'part_svc', + 'hashref' => {}, + 'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc + WHERE pkg_svc.svcpart = part_svc.svcpart + AND pkg_svc.pkgpart = $pkgpart + AND quantity > 0 + ) + AND 0 < ( SELECT count(*) + FROM cust_svc + LEFT JOIN cust_pkg using ( pkgnum ) + WHERE cust_svc.svcpart = part_svc.svcpart + AND pkgnum = $pkgnum + )", + } ); +} + =item status Returns a short status string for this package, currently: @@ -824,26 +976,45 @@ Returns a short status string for this package, currently: sub status { my $self = shift; + my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq; + return 'cancelled' if $self->get('cancel'); return 'suspended' if $self->susp; return 'not yet billed' unless $self->setup; - return 'one-time charge' if $self->part_pkg->freq =~ /^(0|$)/; + return 'one-time charge' if $freq =~ /^(0|$)/; return 'active'; } -=item statuscolor +=item statuses -Returns a hex triplet color string for this package's status. +Class method that returns the list of possible status strings for pacakges +(see L<the status method|/status>). For example: + + @statuses = FS::cust_pkg->statuses(); =cut -my %statuscolor = ( +tie my %statuscolor, 'Tie::IxHash', 'not yet billed' => '000000', 'one-time charge' => '000000', 'active' => '00CC00', 'suspended' => 'FF9900', 'cancelled' => 'FF0000', -); +; + +sub statuses { + my $self = shift; #could be class... + grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway + # mayble split btw one-time vs. recur + keys %statuscolor; +} + +=item statuscolor + +Returns a hex triplet color string for this package's status. + +=cut + sub statuscolor { my $self = shift; $statuscolor{$self->status}; @@ -1163,7 +1334,7 @@ sub reexport { =back -=head1 CLASS METHOD +=head1 CLASS METHODS =over 4 @@ -1178,6 +1349,17 @@ sub recurring_sql { " where cust_pkg.pkgpart = part_pkg.pkgpart ) "; } +=item onetime_sql + +Returns an SQL expression identifying one-time packages. + +=cut + +sub onetime_sql { " + '0' = ( select freq from part_pkg + where cust_pkg.pkgpart = part_pkg.pkgpart ) +"; } + =item active_sql Returns an SQL expression identifying active packages. @@ -1190,6 +1372,19 @@ sub active_sql { " AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 ) "; } +=item inactive_sql + +Returns an SQL expression identifying inactive packages (one-time packages +that are otherwise unsuspended/uncancelled). + +=cut + +sub inactive_sql { " + ". $_[0]->onetime_sql(). " + AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 ) + AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 ) +"; } + =item susp_sql =item suspended_sql @@ -1198,11 +1393,13 @@ Returns an SQL expression identifying suspended packages. =cut sub suspended_sql { susp_sql(@_); } -sub susp_sql { " - ". $_[0]->recurring_sql(). " - AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 ) - AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0 -"; } +sub susp_sql { + #$_[0]->recurring_sql(). ' AND '. + " + ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 ) + AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0 + "; +} =item cancel_sql =item cancelled_sql @@ -1212,10 +1409,10 @@ Returns an SQL exprression identifying cancelled packages. =cut sub cancelled_sql { cancel_sql(@_); } -sub cancel_sql { " - ". $_[0]->recurring_sql(). " - AND cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0 -"; } +sub cancel_sql { + #$_[0]->recurring_sql(). ' AND '. + "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0"; +} =head1 SUBROUTINES @@ -1319,7 +1516,7 @@ sub order { $dbh->rollback if $oldAutoCommit; return "Unable to transfer all services from package ".$old_pkg->pkgnum; } - $error = $old_pkg->cancel; + $error = $old_pkg->cancel( quiet=>1 ); if ($error) { $dbh->rollback; return $error; @@ -1329,6 +1526,44 @@ sub order { ''; } +sub insert_reason { + my ($self, %options) = @_; + + my $otaker = $FS::CurrentUser::CurrentUser->name; + $otaker = $FS::CurrentUser::CurrentUser->username + if (($otaker) eq "User, Legacy"); + + my $cust_pkg_reason = + new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum, + 'reasonnum' => $options{'reason'}, + 'otaker' => $otaker, + 'date' => $options{'date'} + ? $options{'date'} + : time, + }); + return $cust_pkg_reason->insert; +} + +=item set_usage USAGE_VALUE_HASHREF + +USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts +to which they should be set (see L<FS::svc_acct>). Currently seconds, +upbytes, downbytes, and totalbytes are appropriate keys. + +All svc_accts which are part of this package have their values reset. + +=cut + +sub set_usage { + my ($self, $valueref) = @_; + + foreach my $cust_svc ($self->cust_svc){ + my $svc_x = $cust_svc->svc_x; + $svc_x->set_usage($valueref) + if $svc_x->can("set_usage"); + } +} + =back =head1 BUGS diff --git a/FS/FS/cust_pkg_option.pm b/FS/FS/cust_pkg_option.pm new file mode 100644 index 000000000..43a153095 --- /dev/null +++ b/FS/FS/cust_pkg_option.pm @@ -0,0 +1,115 @@ +package FS::cust_pkg_option; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::cust_pkg_option - Object methods for cust_pkg_option records + +=head1 SYNOPSIS + + use FS::cust_pkg_option; + + $record = new FS::cust_pkg_option \%hash; + $record = new FS::cust_pkg_option { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::cust_pkg_option object represents an option key an value for a +customer package. FS::cust_pkg_option inherits from +FS::Record. The following fields are currently supported: + +=over 4 + +=item optionnum - primary key + +=item pkgnum - + +=item optionname - + +=item optionvalue - + + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new option. To add the 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 + +sub table { 'cust_pkg_option'; } + +=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 option. 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('optionnum') + || $self->ut_foreign_key('pkgnum', 'cust_pkg', 'pkgnum') + || $self->ut_text('optionname') + || $self->ut_textn('optionvalue') + ; + return $error if $error; + + $self->SUPER::check; +} + +=back + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::Record>, L<FS::cust_pkg>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/cust_pkg_reason.pm b/FS/FS/cust_pkg_reason.pm new file mode 100644 index 000000000..2f927401f --- /dev/null +++ b/FS/FS/cust_pkg_reason.pm @@ -0,0 +1,122 @@ +package FS::cust_pkg_reason; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::cust_pkg_reason - Object methods for cust_pkg_reason records + +=head1 SYNOPSIS + + use FS::cust_pkg_reason; + + $record = new FS::cust_pkg_reason \%hash; + $record = new FS::cust_pkg_reason { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::cust_pkg_reason object represents a relationship between a cust_pkg +and a reason, for example cancellation or suspension reasons. +FS::cust_pkg_reason inherits from FS::Record. The following fields are +currently supported: + +=over 4 + +=item num - primary key + +=item pkgnum - + +=item reasonnum - + +=item otaker - + +=item date - + + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new cust_pkg_reason. 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 { 'cust_pkg_reason'; } + +=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 cust_pkg_reason. 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('num') + || $self->ut_number('pkgnum') + || $self->ut_number('reasonnum') + || $self->ut_text('otaker') + || $self->ut_numbern('date') + ; + return $error if $error; + + $self->SUPER::check; +} + +=back + +=head1 BUGS + +Here be termites. Don't use on wooden computers. + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/cust_refund.pm b/FS/FS/cust_refund.pm index 8c672b8d7..9cd9bf845 100644 --- a/FS/FS/cust_refund.pm +++ b/FS/FS/cust_refund.pm @@ -1,7 +1,7 @@ package FS::cust_refund; use strict; -use vars qw( @ISA ); +use vars qw( @ISA @encrypted_fields ); use Business::CreditCard; use FS::Record qw( qsearch qsearchs dbh ); use FS::UID qw(getotaker); @@ -9,8 +9,11 @@ use FS::cust_credit; use FS::cust_credit_refund; use FS::cust_pay_refund; use FS::cust_main; +use FS::payinfo_Mixin; -@ISA = qw( FS::Record ); +@ISA = qw( FS::Record FS::payinfo_Mixin ); + +@encrypted_fields = ('payinfo'); =head1 NAME @@ -50,11 +53,11 @@ inherits from FS::Record. The following fields are currently supported: =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), `CHEK' (electronic check/ACH), -`LECB' (Phone bill billing), `BILL' (billing), `CASH' (cash), -`WEST' (Western Union), `MCRD' (Manual credit card), or `COMP' (free) +=item payby - Payment Type (See L<FS::payinfo_Mixin> for valid payby values) + +=item payinfo - Payment Information (See L<FS::payinfo_Mixin> for data format) -=item payinfo - card number, P.O.#, or comp issuer (4-8 lowercase alphanumerics; think username) +=item paymask - Masked payinfo (See L<FS::payinfo_Mixin> for how this works) =item paybatch - text field for tracking card processing @@ -163,14 +166,52 @@ sub insert { =item delete -Currently unimplemented (accounting reasons). +Unless the closed flag is set, deletes this refund and all associated +applications (see L<FS::cust_credit_refund> and L<FS::cust_pay_refund>). =cut sub delete { my $self = shift; return "Can't delete closed refund" if $self->closed =~ /^Y/i; - $self->SUPER::delete(@_); + + 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_credit_refund ( $self->cust_credit_refund ) { + my $error = $cust_credit_refund->delete; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + foreach my $cust_pay_refund ( $self->cust_pay_refund ) { + my $error = $cust_pay_refund->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 @@ -212,29 +253,8 @@ sub check { unless $self->crednum || qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); - $self->payby =~ /^(CARD|CHEK|LECB|BILL|COMP|CASH|WEST|MCRD)$/ - 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; - } + $error = $self->payinfo_check; + return $error if $error; $self->otaker(getotaker); @@ -285,29 +305,11 @@ sub unapplied { sprintf("%.2f", $amount ); } - - -=item payinfo_masked - -Returns a "masked" payinfo field with all but the last four characters replaced -by 'x'es. Useful for displaying credit cards. - -=cut - - -sub payinfo_masked { - my $self = shift; - my $payinfo = $self->payinfo; - 'x'x(length($payinfo)-4). substr($payinfo,(length($payinfo)-4)); -} - - =back =head1 BUGS -Delete and replace methods. payinfo_masked false laziness with cust_main.pm -and cust_pay.pm +Delete and replace methods. =head1 SEE ALSO diff --git a/FS/FS/cust_svc.pm b/FS/FS/cust_svc.pm index ad87cab7e..cdb34cd71 100644 --- a/FS/FS/cust_svc.pm +++ b/FS/FS/cust_svc.pm @@ -1,25 +1,25 @@ package FS::cust_svc; use strict; -use vars qw( @ISA $DEBUG $ignore_quantity ); -use Carp qw( carp cluck ); +use vars qw( @ISA $DEBUG $me $ignore_quantity ); +use Carp; use FS::Conf; 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_domain; -use FS::svc_forward; -use FS::svc_broadband; -use FS::svc_external; use FS::domain_record; use FS::part_export; +use FS::cdr; -@ISA = qw( FS::Record ); +#most FS::svc_ classes are autoloaded in svc_x emthod +use FS::svc_acct; #this one is used in the cache stuff + +@ISA = qw( FS::cust_main_Mixin FS::Record ); $DEBUG = 0; +$me = '[cust_svc]'; $ignore_quantity = 0; @@ -276,58 +276,30 @@ Returns a list consisting of: - The table name (i.e. svc_domain) for this service - svcnum +Usage example: + + my($label, $value, $svcdb) = $cust_svc->label; + =cut sub label { my $self = shift; carp "FS::cust_svc::label called on $self" if $DEBUG; my $svc_x = $self->svc_x - or die "can't find ". $self->part_svc->svcdb. '.svcnum '. $self->svcnum; + or return "can't find ". $self->part_svc->svcdb. '.svcnum '. $self->svcnum; + $self->_svc_label($svc_x); } sub _svc_label { my( $self, $svc_x ) = ( shift, shift ); - my $svcdb = $self->part_svc->svcdb; - my $tag; - if ( $svcdb eq 'svc_acct' ) { - $tag = $svc_x->email(@_); - } elsif ( $svcdb eq 'svc_forward' ) { - if ( $svc_x->srcsvc ) { - my $svc_acct = $svc_x->srcsvc_acct(@_); - $tag = $svc_acct->email(@_); - } else { - $tag = $svc_x->src; - } - $tag .= '->'; - if ( $svc_x->dstsvc ) { - my $svc_acct = $svc_x->dstsvc_acct(@_); - $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_record = $svc_x->domain_record(@_); - $tag = $domain_record->zone; - } elsif ( $svcdb eq 'svc_broadband' ) { - $tag = $svc_x->ip_addr; - } elsif ( $svcdb eq 'svc_external' ) { - my $conf = new FS::Conf; - if ( $conf->config('svc_external-display_type') eq 'artera_turbo' ) { - $tag = sprintf('%010d', $svc_x->id). '-'. - substr('0000000000'.uc($svc_x->title), -10); - } else { - $tag = $svc_x->id. ': '. $svc_x->title; - } - } else { - cluck "warning: asked for label of unsupported svcdb; using svcnum"; - $tag = $svc_x->getfield('svcnum'); - } - - $self->part_svc->svc, $tag, $svcdb, $self->svcnum; + ( + $self->part_svc->svc, + $svc_x->label(@_), + $self->part_svc->svcdb, + $self->svcnum + ); } @@ -344,7 +316,10 @@ sub svc_x { if ( $svcdb eq 'svc_acct' && $self->{'_svc_acct'} ) { $self->{'_svc_acct'}; } else { - #require "FS/$svcdb.pm"; + require "FS/$svcdb.pm"; + warn "$me svc_x: part_svc.svcpart ". $self->part_svc->svcpart. + ", so searching for $svcdb.svcnum ". $self->svcnum. "\n" + if $DEBUG; qsearchs( $svcdb, { 'svcnum' => $self->svcnum } ); } } @@ -570,6 +545,49 @@ sub get_session_history { } +=item get_cdrs_for_update + +Returns (and SELECTs "FOR UPDATE") all unprocessed (freesidestatus NULL) CDR +objects (see L<FS::cdr>) associated with this service. + +Currently CDRs are associated with svc_acct services via a DID in the +username. This part is rather tenative and still subject to change... + +=cut + +sub get_cdrs_for_update { + my($self, %options) = @_; + + my $default_prefix = $options{'default_prefix'}; + + #CDRs are now associated with svc_phone services via svc_phone.phonenum + #return () unless $self->svc_x->isa('FS::svc_phone'); + return () unless $self->part_svc->svcdb eq 'svc_phone'; + my $number = $self->svc_x->phonenum; + + my @cdrs = + qsearch( { + 'table' => 'cdr', + 'hashref' => { 'freesidestatus' => '', + 'charged_party' => $number + }, + 'extra_sql' => 'FOR UPDATE', + } ); + + if ( length($default_prefix) ) { + push @cdrs, + qsearch( { + 'table' => 'cdr', + 'hashref' => { 'freesidestatus' => '', + 'charged_party' => "$default_prefix$number", + }, + 'extra_sql' => 'FOR UPDATE', + } ); + } + + @cdrs; +} + =item pkg_svc Returns the pkg_svc record for for this service, if applicable. diff --git a/FS/FS/cust_tax_exempt.pm b/FS/FS/cust_tax_exempt.pm index da0de000a..3e398877a 100644 --- a/FS/FS/cust_tax_exempt.pm +++ b/FS/FS/cust_tax_exempt.pm @@ -3,6 +3,8 @@ package FS::cust_tax_exempt; use strict; use vars qw( @ISA ); use FS::Record qw( qsearch qsearchs ); +use FS::cust_main; +use FS::cust_main_county; @ISA = qw(FS::Record); @@ -27,7 +29,7 @@ FS::cust_tax_exempt - Object methods for cust_tax_exempt records =head1 DESCRIPTION -An FS::cust_tax_exempt object represents a historical record of a customer tax +An FS::cust_tax_exempt object represents a record of an old-style customer tax exemption. Currently this is only used for "texas tax". FS::cust_tax_exempt inherits from FS::Record. The following fields are currently supported: @@ -47,6 +49,12 @@ inherits from FS::Record. The following fields are currently supported: =back +=head1 NOTE + +Old-style customer tax exemptions are only useful for legacy migrations - if +you are looking for current customer tax exemption data see +L<FS::cust_tax_exempt_pkg>. + =head1 METHODS =over 4 @@ -115,6 +123,17 @@ sub check { ; } +=item cust_main_county + +Returns the FS::cust_main_county object associated with this tax exemption. + +=cut + +sub cust_main_county { + my $self = shift; + qsearchs( 'cust_main_county', { 'taxnum' => $self->taxnum } ); +} + =back =head1 BUGS diff --git a/FS/FS/cust_tax_exempt_pkg.pm b/FS/FS/cust_tax_exempt_pkg.pm new file mode 100644 index 000000000..128921b9c --- /dev/null +++ b/FS/FS/cust_tax_exempt_pkg.pm @@ -0,0 +1,136 @@ +package FS::cust_tax_exempt_pkg; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); +use FS::cust_main_Mixin; +use FS::cust_bill_pkg; +use FS::cust_main_county; + +@ISA = qw( FS::cust_main_Mixin FS::Record ); + +=head1 NAME + +FS::cust_tax_exempt_pkg - Object methods for cust_tax_exempt_pkg records + +=head1 SYNOPSIS + + use FS::cust_tax_exempt_pkg; + + $record = new FS::cust_tax_exempt_pkg \%hash; + $record = new FS::cust_tax_exempt_pkg { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::cust_tax_exempt_pkg object represents a record of a customer tax +exemption. Currently this is only used for "texas tax". FS::cust_tax_exempt +inherits from FS::Record. The following fields are currently supported: + +=over 4 + +=item exemptpkgnum - primary key + +=item billpkgnum - invoice line item (see L<FS::cust_bill_pkg>) + +=item taxnum - tax rate (see L<FS::cust_main_county>) + +=item year + +=item month + +=item amount + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new exemption record. To add the examption 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 + +# the new method can be inherited from FS::Record, if a table method is defined + +sub table { 'cust_tax_exempt_pkg'; } + +=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 exemption record. 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('exemptnum') +# || $self->ut_foreign_key('custnum', 'cust_main', 'custnum') + || $self->ut_foreign_key('billpkgnum', 'cust_bill_pkg', 'billpkgnum') + || $self->ut_foreign_key('taxnum', 'cust_main_county', 'taxnum') + || $self->ut_number('year') #check better + || $self->ut_number('month') #check better + || $self->ut_money('amount') + || $self->SUPER::check + ; +} + +=back + +=head1 BUGS + +Texas tax is still a royal pain in the ass. + +=head1 SEE ALSO + +L<FS::cust_main_county>, L<FS::cust_bill_pkg>, L<FS::Record>, schema.html from +the base documentation. + +=cut + +1; + diff --git a/FS/FS/domain_record.pm b/FS/FS/domain_record.pm index 3c65a1a05..6513abf25 100644 --- a/FS/FS/domain_record.pm +++ b/FS/FS/domain_record.pm @@ -59,7 +59,7 @@ supported: =item new HASHREF -Creates a new entry. To add the example to the database, see L<"insert">. +Creates a new entry. To add the entry 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. @@ -229,7 +229,7 @@ sub replace { =item check -Checks all fields to make sure this is a valid example. If there is +Checks all fields to make sure this is a valid entry. If there is an error, returns the error, otherwise returns false. Called by the insert and replace methods. diff --git a/FS/FS/h_cust_bill.pm b/FS/FS/h_cust_bill.pm new file mode 100644 index 000000000..7a3d81146 --- /dev/null +++ b/FS/FS/h_cust_bill.pm @@ -0,0 +1,33 @@ +package FS::h_cust_bill; + +use strict; +use vars qw( @ISA ); +use FS::h_Common; +use FS::cust_bill; + +@ISA = qw( FS::h_Common FS::cust_bill ); + +sub table { 'h_cust_bill' }; + +=head1 NAME + +FS::h_cust_bill - Historical record of customer tax changes (old-style) + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +An FS::h_cust_bill object represents historical changes to invoices. +FS::h_cust_bill inherits from FS::h_Common and FS::cust_bill. + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::cust_bill>, L<FS::h_Common>, L<FS::Record>, schema.html from the base +documentation. + +=cut + +1; + diff --git a/FS/FS/h_cust_tax_exempt.pm b/FS/FS/h_cust_tax_exempt.pm new file mode 100644 index 000000000..9d2318bd5 --- /dev/null +++ b/FS/FS/h_cust_tax_exempt.pm @@ -0,0 +1,40 @@ +package FS::h_cust_tax_exempt; + +use strict; +use vars qw( @ISA ); +use FS::h_Common; +use FS::cust_tax_exempt; + +@ISA = qw( FS::h_Common FS::cust_tax_exempt ); + +sub table { 'h_cust_tax_exempt' }; + +=head1 NAME + +FS::h_cust_tax_exempt - Historical record of customer tax changes (old-style) + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +An FS::h_cust_tax_exempt object represents historical changes to old-style +customer tax exemptions. FS::h_cust_tax_exempt inherits from FS::h_Common and +FS::cust_tax_exempt. + +=head1 NOTE + +Old-style customer tax exemptions are only useful for legacy migrations - if +you are looking for current customer tax exemption data see +L<FS::cust_tax_exempt_pkg>. + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::cust_tax_exempt>, L<FS::cust_tax_exempt_pkg>, L<FS::h_Common>, +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/h_svc_phone.pm b/FS/FS/h_svc_phone.pm new file mode 100644 index 000000000..95898c7b0 --- /dev/null +++ b/FS/FS/h_svc_phone.pm @@ -0,0 +1,33 @@ +package FS::h_svc_phone; + +use strict; +use vars qw( @ISA ); +use FS::h_Common; +use FS::svc_phone; + +@ISA = qw( FS::h_Common FS::svc_phone ); + +sub table { 'h_svc_phone' }; + +=head1 NAME + +FS::h_svc_phone - Historical phone number objects + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +An FS::h_svc_phone object represents a historical phone number. +FS::h_svc_phone inherits from FS::h_Common and FS::svc_phone. + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::h_Common>, L<FS::svc_phone>, L<FS::Record>, schema.html from the base +documentation. + +=cut + +1; + diff --git a/FS/FS/inventory_class.pm b/FS/FS/inventory_class.pm new file mode 100644 index 000000000..508889bca --- /dev/null +++ b/FS/FS/inventory_class.pm @@ -0,0 +1,164 @@ +package FS::inventory_class; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( dbh qsearch qsearchs ); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::inventory_class - Object methods for inventory_class records + +=head1 SYNOPSIS + + use FS::inventory_class; + + $record = new FS::inventory_class \%hash; + $record = new FS::inventory_class { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::inventory_class object represents a class of inventory, such as "DID +numbers" or "physical equipment serials". FS::inventory_class inherits from +FS::Record. The following fields are currently supported: + +=over 4 + +=item classnum - primary key + +=item classname - Name of this class + + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new inventory class. To add the class 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 { 'inventory_class'; } + +=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 inventory class. 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('classnum') + || $self->ut_textn('classname') + ; + return $error if $error; + + $self->SUPER::check; +} + +=item num_avail + +Returns the number of available (unused/unallocated) inventory items of this +class (see L<FS::inventory_item>). + +=cut + +sub num_avail { + shift->num_sql('( svcnum IS NULL OR svcnum = 0 )'); +} + +sub num_sql { + my( $self, $sql ) = @_; + $sql = "AND $sql" if length($sql); + my $statement = + "SELECT COUNT(*) FROM inventory_item WHERE classnum = ? $sql"; + my $sth = dbh->prepare($statement) or die dbh->errstr. " preparing $statement"; + $sth->execute($self->classnum) or die $sth->errstr. " executing $statement"; + $sth->fetchrow_arrayref->[0]; +} + +=item num_used + +Returns the number of used (allocated) inventory items of this class (see +L<FS::inventory_class>). + +=cut + +sub num_used { + shift->num_sql("svcnum IS NOT NULL AND svcnum > 0 "); +} + +=item num_total + +Returns the total number of inventory items of this class (see +L<FS::inventory_class>). + +=cut + +sub num_total { + shift->num_sql(''); +} + +=back + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::inventory_item>, L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/inventory_item.pm b/FS/FS/inventory_item.pm new file mode 100644 index 000000000..7fa350f2a --- /dev/null +++ b/FS/FS/inventory_item.pm @@ -0,0 +1,204 @@ +package FS::inventory_item; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( dbh qsearch qsearchs ); +use FS::cust_main_Mixin; +use FS::inventory_class; +use FS::cust_svc; + +@ISA = qw( FS::cust_main_Mixin FS::Record ); + +=head1 NAME + +FS::inventory_item - Object methods for inventory_item records + +=head1 SYNOPSIS + + use FS::inventory_item; + + $record = new FS::inventory_item \%hash; + $record = new FS::inventory_item { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::inventory_item object represents a specific piece of (real or virtual) +inventory, such as a specific DID or serial number. FS::inventory_item +inherits from FS::Record. The following fields are currently supported: + +=over 4 + +=item itemnum - primary key + +=item classnum - Inventory class (see L<FS::inventory_class>) + +=item item - Item identifier (unique within its inventory class) + +=item svcnum - Customer servcie (see L<FS::cust_svc>) + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new item. To add the item 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 { 'inventory_item'; } + +=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 item. 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('itemnum') + || $self->ut_foreign_key('classnum', 'inventory_class', 'classnum' ) + || $self->ut_text('item') + || $self->ut_foreign_keyn('svcnum', 'cust_svc', 'svcnum' ) + ; + return $error if $error; + + $self->SUPER::check; +} + +=item cust_svc + +Returns the customer service associated with this inventory item, if the +item has been used (see L<FS::cust_svc>). + +=cut + +sub cust_svc { + my $self = shift; + return '' unless $self->svcnum; + qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } ); +} + +=back + +=head1 CLASS METHODS + +=over 4 + +=item batch_import + +=cut + +sub batch_import { + my $param = shift; + + my $fh = $param->{filehandle}; + + my $imported = 0; + + 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 $line; + while ( defined($line=<$fh>) ) { + + chomp $line; + + my $inventory_item = new FS::inventory_item { + 'classnum' => $param->{'classnum'}, + 'item' => $line, + }; + + my $error = $inventory_item->insert; + + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + + #or just skip? + #next; + } + + $imported++; + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + #might want to disable this if we skip records for any reason... + return "Empty file!" unless $imported; + + ''; + +} + +=back + +=head1 BUGS + +maybe batch_import should be a regular method in FS::inventory_class + +=head1 SEE ALSO + +L<inventory_class>, L<cust_svc>, L<FS::Record>, schema.html from the base +documentation. + +=cut + +1; + diff --git a/FS/FS/m2m_Common.pm b/FS/FS/m2m_Common.pm new file mode 100644 index 000000000..5dc2a8ec8 --- /dev/null +++ b/FS/FS/m2m_Common.pm @@ -0,0 +1,144 @@ +package FS::m2m_Common; + +use strict; +use vars qw( @ISA $DEBUG ); +use FS::Schema qw( dbdef ); +use FS::Record qw( qsearch qsearchs dbh ); + +#hmm. well. we seem to be used as a mixin. +#@ISA = qw( FS::Record ); + +$DEBUG = 0; + +=head1 NAME + +FS::m2m_Common - Mixin class for classes in a many-to-many relationship + +=head1 SYNOPSIS + +use FS::m2m_Common; + +@ISA = qw( FS::m2m_Common FS::Record ); + +=head1 DESCRIPTION + +FS::m2m_Common is intended as a mixin class for classes which have a +many-to-many relationship with another table (via a linking table). + +Note: It is currently assumed that the link table contains two fields +named the same as the primary keys of ths base and target tables. + +=head1 METHODS + +=over 4 + +=item process_m2m OPTION => VALUE, ... + +Available options: + +link_table (required) - + +target_table (required) - + +params (required) - hashref; keys are primary key values in target_table (values are boolean). For convenience, keys may optionally be prefixed with the name +of the primary key, as in agentnum54 instead of 54, or passed as an arrayref +of values. + +=cut + +sub process_m2m { + my( $self, %opt ) = @_; + + my $self_pkey = $self->dbdef_table->primary_key; + my %hash = ( $self_pkey => $self->$self_pkey() ); + + my $link_table = $self->_load_table($opt{'link_table'}); + + my $target_table = $self->_load_table($opt{'target_table'}); + my $target_pkey = dbdef->table($target_table)->primary_key; + + if ( ref($opt{'params'}) eq 'ARRAY' ) { + $opt{'params'} = { map { $_=>1 } @{$opt{'params'}} }; + } + + 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 $del_obj ( + grep { + my $targetnum = $_->$target_pkey(); + ( ! $opt{'params'}->{$targetnum} + && ! $opt{'params'}->{"$target_pkey$targetnum"} + ); + } + qsearch( $link_table, \%hash ) + ) { + my $error = $del_obj->delete; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + foreach my $add_targetnum ( + grep { ! qsearchs( $link_table, { %hash, $target_pkey => $_ } ) } + map { /^($target_pkey)?(\d+)$/; $2; } + grep { /^($target_pkey)?(\d+)$/ } + grep { $opt{'params'}->{$_} } + keys %{ $opt{'params'} } + ) { + + my $add_obj = "FS::$link_table"->new( { + %hash, + $target_pkey => $add_targetnum, + }); + my $error = $add_obj->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; +} + +sub _load_table { + my( $self, $table ) = @_; + eval "use FS::$table"; + die $@ if $@; + $table; +} + +#=item target_table +# +#=cut +# +#sub target_table { +# my $self = shift; +# my $target_table = $self->_target_table; +# eval "use FS::$target_table"; +# die $@ if $@; +# $target_table; +#} + +=back + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::Record> + +=cut + +1; + diff --git a/FS/FS/m2name_Common.pm b/FS/FS/m2name_Common.pm new file mode 100644 index 000000000..7c9637e27 --- /dev/null +++ b/FS/FS/m2name_Common.pm @@ -0,0 +1,95 @@ +package FS::m2name_Common; + +use strict; +use vars qw( @ISA $DEBUG ); +use FS::Schema qw( dbdef ); +use FS::Record qw( qsearch qsearchs ); #dbh ); + +@ISA = qw( FS::Record ); + +$DEBUG = 0; + +=head1 NAME + +FS::m2name_Common - Base class for tables with a related table listing names + +=head1 SYNOPSIS + +use FS::m2name_Common; + +@ISA = qw( FS::m2name_Common ); + +=head1 DESCRIPTION + +FS::m2name_Common is intended as a base class for classes which have a +related table that lists names. + +=head1 METHODS + +=over 4 + +=item process_m2name + +=cut + +sub process_m2name { + my( $self, %opt ) = @_; + + my $self_pkey = $self->dbdef_table->primary_key; + my $link_sourcekey = $opt{'num_col'} || $self_pkey; + + my $link_table = $self->_load_table($opt{'link_table'}); + + my $link_static = $opt{'link_static'} || {}; + + foreach my $name ( @{ $opt{'names_list'} } ) { + + my $obj = qsearchs( $link_table, { + $link_sourcekey => $self->$self_pkey(), + $opt{'name_col'} => $name, + %$link_static, + }); + + if ( $obj && ! $opt{'params'}->{"$link_table.$name"} ) { + + my $d_obj = $obj; #need to save $obj for below. + my $error = $d_obj->delete; + die "error deleting $d_obj for $link_table.$name: $error" if $error; + + } elsif ( $opt{'params'}->{"$link_table.$name"} && ! $obj ) { + + #ok to clobber it now (but bad form nonetheless?) + #$obj = new "FS::$link_table" ( { + $obj = "FS::$link_table"->new( { + $link_sourcekey => $self->$self_pkey(), + $opt{'name_col'} => $name, + %$link_static, + }); + my $error = $obj->insert; + die "error inserting $obj for $link_table.$name: $error" if $error; + } + + } + + ''; +} + +sub _load_table { + my( $self, $table ) = @_; + eval "use FS::$table"; + die $@ if $@; + $table; +} + +=back + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::Record> + +=cut + +1; + diff --git a/FS/FS/msgcat.pm b/FS/FS/msgcat.pm index 855b8b291..cbdc1d633 100644 --- a/FS/FS/msgcat.pm +++ b/FS/FS/msgcat.pm @@ -52,7 +52,8 @@ If you just want to B<use> message catalogs, see L<FS::Msgcat>. =item new HASHREF -Creates a new example. To add the example to the database, see L<"insert">. +Creates a new message catalog entry. To add the message catalog entry 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. @@ -91,8 +92,8 @@ returns the error, otherwise returns false. =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 +Checks all fields to make sure this is a valid message catalog entry. If there +is an error, returns the error, otherwise returns false. Called by the insert and replace methods. =cut diff --git a/FS/FS/nas.pm b/FS/FS/nas.pm index 3495339e0..97b0ea17d 100644 --- a/FS/FS/nas.pm +++ b/FS/FS/nas.pm @@ -98,7 +98,7 @@ returns the error, otherwise returns false. =item check -Checks all fields to make sure this is a valid example. If there is +Checks all fields to make sure this is a valid NAS. If there is an error, returns the error, otherwise returns false. Called by the insert and replace methods. diff --git a/FS/FS/option_Common.pm b/FS/FS/option_Common.pm index f258fa1d6..2950b28d4 100644 --- a/FS/FS/option_Common.pm +++ b/FS/FS/option_Common.pm @@ -2,6 +2,7 @@ package FS::option_Common; use strict; use vars qw( @ISA $DEBUG ); +use Scalar::Util qw( blessed ); use FS::Record qw( qsearch qsearchs dbh ); @ISA = qw( FS::Record ); @@ -18,6 +19,11 @@ use FS::option_Common; @ISA = qw( FS::option_Common ); +#optional for non-standard names +sub _option_table { 'table_name'; } #defaults to ${table}_option +sub _option_namecol { 'column_name'; } #defaults to optionname +sub _option_valuecol { 'column_name'; } #defaults to optionvalue + =head1 DESCRIPTION FS::option_Common is intended as a base class for classes which have a @@ -66,14 +72,17 @@ sub insert { return $error; } - my $pkey = $self->pkey; + my $pkey = $self->primary_key; my $option_table = $self->option_table; + my $namecol = $self->_option_namecol; + my $valuecol = $self->_option_valuecol; + foreach my $optionname ( keys %{$options} ) { my $href = { - $pkey => $self->get($pkey), - 'optionname' => $optionname, - 'optionvalue' => $options->{$optionname}, + $pkey => $self->get($pkey), + $namecol => $optionname, + $valuecol => $options->{$optionname}, }; #my $option_record = eval "new FS::$option_table \$href"; @@ -123,7 +132,7 @@ sub delete { return $error; } - my $pkey = $self->pkey; + my $pkey = $self->primary_key; #my $option_table = $self->option_table; foreach my $obj ( $self->option_objects ) { @@ -140,7 +149,7 @@ sub delete { } -=item replace [ HASHREF | OPTION => VALUE ... ] +=item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ] Replaces the OLD_RECORD with this one in the database. If there is an error, returns the error, otherwise returns false. @@ -152,12 +161,17 @@ created or modified (see L<FS::part_export_option>). sub replace { my $self = shift; - my $old = shift; + + my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') ) + ? shift + : $self->replace_old; + my $options = ( ref($_[0]) eq 'HASH' ) ? shift : { @_ }; - warn "FS::option_Common::insert called on $self with options ". + + warn "FS::option_Common::replace called on $self with options ". join(', ', map "$_ => ". $options->{$_}, keys %$options) if $DEBUG; @@ -178,30 +192,42 @@ sub replace { return $error; } - my $pkey = $self->pkey; + my $pkey = $self->primary_key; my $option_table = $self->option_table; + my $namecol = $self->_option_namecol; + my $valuecol = $self->_option_valuecol; + foreach my $optionname ( keys %{$options} ) { - my $old = qsearchs( $option_table, { - $pkey => $self->get($pkey), - 'optionname' => $optionname, + + warn "FS::option_Common::replace: inserting or replacing option: $optionname" + if $DEBUG > 1; + + my $oldopt = qsearchs( $option_table, { + $pkey => $self->get($pkey), + $namecol => $optionname, } ); my $href = { - $pkey => $self->get($pkey), - 'optionname' => $optionname, - 'optionvalue' => $options->{$optionname}, + $pkey => $self->get($pkey), + $namecol => $optionname, + $valuecol => $options->{$optionname}, }; - #my $new = eval "new FS::$option_table \$href"; + #my $newopt = eval "new FS::$option_table \$href"; #if ( $@ ) { # $dbh->rollback if $oldAutoCommit; # return $@; #} - my $new = "FS::$option_table"->new($href); + my $newopt = "FS::$option_table"->new($href); + + my $opt_pkey = $newopt->primary_key; - $new->optionnum($old->optionnum) if $old; - my $error = $old ? $new->replace($old) : $new->insert; + $newopt->$opt_pkey($oldopt->$opt_pkey) if $oldopt; + warn "FS::option_Common::replace: ". + ( $oldopt ? "$newopt -> replace($oldopt)" : "$newopt -> insert" ) + if $DEBUG > 2; + my $error = $oldopt ? $newopt->replace($oldopt) : $newopt->insert; if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; @@ -210,7 +236,7 @@ sub replace { #remove extraneous old options foreach my $opt ( - grep { !exists $options->{$_->optionname} } $old->option_objects + grep { !exists $options->{$_->$namecol()} } $old->option_objects ) { my $error = $opt->delete; if ( $error ) { @@ -233,7 +259,7 @@ Returns all options as FS::I<tablename>_option objects. sub option_objects { my $self = shift; - my $pkey = $self->pkey; + my $pkey = $self->primary_key; my $option_table = $self->option_table; qsearch($option_table, { $pkey => $self->get($pkey) } ); } @@ -246,7 +272,9 @@ Returns a list of option names and values suitable for assigning to a hash. sub options { my $self = shift; - map { $_->optionname => $_->optionvalue } $self->option_objects; + my $namecol = $self->_option_namecol; + my $valuecol = $self->_option_valuecol; + map { $_->$namecol() => $_->$valuecol() } $self->option_objects; } =item option OPTIONNAME @@ -257,30 +285,35 @@ Returns the option value for the given name, or the empty string. sub option { my $self = shift; - my $pkey = $self->pkey; + my $pkey = $self->primary_key; my $option_table = $self->option_table; - my $obj = - qsearchs($option_table, { - $pkey => $self->get($pkey), - optionname => shift, - } ); - $obj ? $obj->optionvalue : ''; + my $namecol = $self->_option_namecol; + my $valuecol = $self->_option_valuecol; + my $hashref = { + $pkey => $self->get($pkey), + $namecol => shift, + }; + warn "$self -> option: searching for ". + join(' / ', map { "$_ => ". $hashref->{$_} } keys %$hashref ) + if $DEBUG; + my $obj = qsearchs($option_table, $hashref); + $obj ? $obj->$valuecol() : ''; } -sub pkey { - my $self = shift; - my $pkey = $self->dbdef_table->primary_key; -} - sub option_table { my $self = shift; - my $option_table = $self->table . '_option'; + my $option_table = $self->_option_table; eval "use FS::$option_table"; die $@ if $@; $option_table; } +#defaults +sub _option_table { shift->table .'_option'; } +sub _option_namecol { 'optionname'; } +sub _option_valuecol { 'optionvalue'; } + =back =head1 BUGS diff --git a/FS/FS/part_bill_event.pm b/FS/FS/part_bill_event.pm index 8143e3473..683f48423 100644 --- a/FS/FS/part_bill_event.pm +++ b/FS/FS/part_bill_event.pm @@ -1,11 +1,13 @@ package FS::part_bill_event; use strict; -use vars qw( @ISA ); -use FS::Record qw( qsearch qsearchs ); +use vars qw( @ISA $DEBUG @EXPORT_OK ); +use FS::Record qw( dbh qsearch qsearchs ); use FS::Conf; -@ISA = qw(FS::Record); +@ISA = qw( FS::Record ); +@EXPORT_OK = qw( due_events ); +$DEBUG = 0; =head1 NAME @@ -26,6 +28,13 @@ FS::part_bill_event - Object methods for part_bill_event records $error = $record->check; + $error = $record->do_event( $direct_object ); + + @events = due_events ( { 'record' => $event_triggering_record, + 'payby' => $payby, + 'event_time => $_date, + 'extra_sql => $extra } ); + =head1 DESCRIPTION An FS::part_bill_event object represents an invoice event definition - @@ -51,6 +60,8 @@ FS::Record. The following fields are currently supported: =item plandata - additional plan data +=item reason - an associated reason for this event to fire + =item disabled - Disabled flag, empty or `Y' =back @@ -61,8 +72,8 @@ FS::Record. The following fields are currently supported: =item new HASHREF -Creates a new invoice event definition. To add the example to the database, -see L<"insert">. +Creates a new invoice event definition. To add the invoice event definition 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. @@ -122,13 +133,16 @@ sub check { my $c = $self->eventcode; + #yay, these regexen will go away with the event refactor + $c =~ /^\s*\$cust_main\->(suspend|cancel|invoicing_list_addpost|bill|collect)\(\);\s*("";)?\s*$/ - or $c =~ /^\s*\$cust_bill\->(comp|realtime_(card|ach|lec)|batch_card|send)\(\);\s*$/ + or $c =~ /^\s*\$cust_bill\->(comp|realtime_(card|ach|lec)|batch_card|send)\((%options)*\);\s*$/ or $c =~ /^\s*\$cust_bill\->send(_if_newest)?\(\'[\w\-\s]+\'\s*(,\s*(\d+|\[\s*\d+(,\s*\d+)*\s*\])\s*,\s*'[\w\@\.\-\+]*'\s*)?\);\s*$/ - or $c =~ /^\s*\$cust_main\->apply_payments; \$cust_main->apply_credits; "";\s*$/ +# or $c =~ /^\s*\$cust_main\->apply_payments; \$cust_main->apply_credits; "";\s*$/ + or $c =~ /^\s*\$cust_main\->apply_payments_and_credits; "";\s*$/ or $c =~ /^\s*\$cust_main\->charge\( \s*\d*\.?\d*\s*,\s*\'[\w \!\@\#\$\%\&\(\)\-\+\;\:\"\,\.\?\/]*\'\s*\);\s*$/ @@ -144,7 +158,7 @@ sub check { } my $error = $self->ut_numbern('eventpart') - || $self->ut_enum('payby', [qw( CARD DCRD CHEK DCHK LECB BILL COMP )] ) + || $self->ut_enum('payby', [qw( CARD DCLN DCRD CHEK DCHK LECB BILL COMP )] ) || $self->ut_text('event') || $self->ut_anything('eventcode') || $self->ut_number('seconds') @@ -152,6 +166,7 @@ sub check { || $self->ut_number('weight') || $self->ut_textn('plan') || $self->ut_anything('plandata') + || $self->ut_numbern('reason') ; #|| $self->ut_snumber('seconds') return $error if $error; @@ -175,6 +190,11 @@ sub check { } } + if ($self->reason){ + my $reasonr = qsearchs('reason', {'reasonnum' => $self->reason}); + return "Unknown reason" unless $reasonr; + } + $self->SUPER::check; } @@ -197,6 +217,119 @@ sub templatename { } } +=item due_events + +Returns the list of events due, if any, or false if there is none. +Requires record and payby, but event_time and extra_sql are optional. + +=cut + +sub due_events { + my ($record, $payby, $event_time, $extra_sql) = @_; + my $interval = 0; + if ($record->_date){ + $event_time = time unless $event_time; + $interval = $event_time - $record->_date; + } + sort { $a->seconds <=> $b->seconds + || $a->weight <=> $b->weight + || $a->eventpart <=> $b->eventpart } + grep { $_->seconds <= ( $interval ) + && ! qsearch( 'cust_bill_event', { + 'invnum' => $record->get($record->dbdef_table->primary_key), + 'eventpart' => $_->eventpart, + 'status' => 'done', + } ) + } + qsearch( { + 'table' => 'part_bill_event', + 'hashref' => { 'payby' => $payby, + 'disabled' => '', }, + 'extra_sql' => $extra_sql, + } ); + + +} + +=item do_event + +Performs the event and returns any errors that occur. +Requires a record on which to perform the event. +Should only be performed inside a transaction. + +=cut + +sub do_event { + my ($self, $object, %options) = @_; + warn " calling event (". $self->eventcode. ") for " . $object->table . " " , + $object->get($object->dbdef_table->primary_key) . "\n" if $DEBUG > 1; + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + + # for "callback" -- heh + my $cust_main = $object->cust_main; + my $cust_bill; + if ($object->table eq 'cust_bill'){ + $cust_bill = $object; + } + my $cust_pay_batch; + if ($object->table eq 'cust_pay_batch'){ + $cust_pay_batch = $object; + } + + my $error; + { + local $SIG{__DIE__}; # don't want Mason __DIE__ handler active + $error = eval $self->eventcode; + } + + my $status = ''; + my $statustext = ''; + if ( $@ ) { + $status = 'failed'; + $statustext = $@; + } elsif ( $error ) { + $status = 'done'; + $statustext = $error; + } else { + $status = 'done'; + } + + #add cust_bill_event + my $cust_bill_event = new FS::cust_bill_event { +# 'invnum' => $object->get($object->dbdef_table->primary_key), + 'invnum' => $object->invnum, + 'eventpart' => $self->eventpart, + '_date' => time, + 'status' => $status, + 'statustext' => $statustext, + }; + $error = $cust_bill_event->insert; + if ( $error ) { + my $e = 'WARNING: Event run but database not updated - '. + 'error inserting cust_bill_event, invnum #'. $object->invnum . + ', eventpart '. $self->eventpart.": $error"; + warn $e; + return $e; + } + ''; +} + +=item reasontext + +Returns the text of any reason associated with this event. + +=cut + +sub reasontext { + my $self = shift; + my $r = qsearchs('reason', { 'reasonnum' => $self->reason }); + if ($r){ + $r->reason; + }else{ + ''; + } +} =back diff --git a/FS/FS/part_export.pm b/FS/FS/part_export.pm index dce2d2a44..6adcab94d 100644 --- a/FS/FS/part_export.pm +++ b/FS/FS/part_export.pm @@ -10,6 +10,9 @@ use FS::part_svc; use FS::part_export_option; use FS::export_svc; +#for export modules, though they should probably just use it themselves +use FS::queue; + @ISA = qw( FS::option_Common ); @EXPORT_OK = qw(export_info); diff --git a/FS/FS/part_export/acct_plesk.pm b/FS/FS/part_export/acct_plesk.pm new file mode 100644 index 000000000..1be820a75 --- /dev/null +++ b/FS/FS/part_export/acct_plesk.pm @@ -0,0 +1,121 @@ +package FS::part_export::acct_plesk; + +use vars qw(@ISA %info); +use Tie::IxHash; +use FS::part_export; + +@ISA = qw(FS::part_export); + +tie my %options, 'Tie::IxHash', + 'URL' => { label=>'URL' }, + 'login' => { label=>'Login' }, + 'password' => { label=>'Password' }, + 'debug' => { label=>'Enable debugging', + type=>'checkbox' }, +; + +%info = ( + 'svc' => 'svc_acct', + 'desc' => 'Real-time export to Plesk managed mail service', + 'options'=> \%options, + 'notes' => <<'END' +Real-time export to +<a href="http://www.swsoft.com/">Plesk</a> managed server. +Requires installation of +<a href="http://search.cpan.org/dist/Net-Plesk">Net::Plesk</a> +from CPAN. +END +); + +sub rebless { shift; } + +# experiment: want the status of these right away (don't want account to +# create or whatever and then get error in the queue from dup username or +# something), so no queueing + +sub _export_insert { + my( $self, $svc_acct ) = (shift, shift); + + $self->_plesk_command( 'mail_add', + $svc_acct->domain, + $svc_acct->username, + $svc_acct->_password, + ) || + $self->_export_unsuspend($svc_acct); +} + +sub _plesk_command { + my( $self, $method, $domain, @args ) = @_; + + eval "use Net::Plesk;"; + return $@ if $@; + + local($Net::Plesk::DEBUG) = 1 + if $self->option('debug'); + + my $plesk = new Net::Plesk ( + 'POST' => $self->option('URL'), + ':HTTP_AUTH_LOGIN' => $self->option('login'), + ':HTTP_AUTH_PASSWD' => $self->option('password'), + ); + + my $dresponse = $plesk->domain_get( $domain ); + return $dresponse->errortext unless $dresponse->is_success; + my $domainID = $dresponse->id; + + my $response = $plesk->$method($dresponse->id, @args); + return $response->errortext unless $response->is_success; + ''; + +} + +sub _export_replace { + my( $self, $new, $old ) = (shift, shift, shift); + + return "can't change domain with Plesk" + if $old->domain ne $new->domain; + return "can't change username with Plesk" + if $old->username ne $new->username; + return '' unless $old->_password ne $new->_password; + + $self->_plesk_command( 'mail_set', + $new->domain, + $new->username, + $new->_password, + $old->cust_svc->cust_pkg->susp ? 0 : 1, + ); +} + +sub _export_delete { + my( $self, $svc_acct ) = (shift, shift); + + $self->_plesk_command( 'mail_remove', + $svc_acct->domain, + $svc_acct->username, + ); +} + +sub _export_suspend { + my( $self, $svc_acct ) = (shift, shift); + + $self->_plesk_command( 'mail_set', + $svc_acct->domain, + $svc_acct->username, + $svc_acct->_password, + 0, + ); +} + +sub _export_unsuspend { + my( $self, $svc_acct ) = (shift, shift); + + $self->_plesk_command( 'mail_set', + $svc_acct->domain, + $svc_acct->username, + $svc_acct->_password, + 1, + ); +} + +1; + diff --git a/FS/FS/part_export/acct_sql.pm b/FS/FS/part_export/acct_sql.pm index 4b92e80f1..9f1ae7b5c 100644 --- a/FS/FS/part_export/acct_sql.pm +++ b/FS/FS/part_export/acct_sql.pm @@ -17,6 +17,10 @@ tie my %options, 'Tie::IxHash', 'Database schema mapping to Freeside methods.', type => 'textarea', }, + 'static' => { label => + 'Database schema mapping to static values.', + type => 'textarea', + }, 'primary_key' => { label => 'Database primary key' }, 'crypt' => { label => 'Password encryption', type=>'select', options=>[qw(crypt md5)], @@ -60,6 +64,17 @@ my $postfix_courierimap_alias_map = join('\n', map "$_ $postfix_courierimap_alias_map{$_}", keys %postfix_courierimap_alias_map ); +tie my %postfix_native_mailbox_map, 'Tie::IxHash', + 'userid' => 'email', + 'uid' => 'uid', + 'gid' => 'gid', + 'password' => 'ldap_password', + 'mail' => 'domain_slash_username', +; +my $postfix_native_mailbox_map = + join('\n', map "$_ $postfix_native_mailbox_map{$_}", + keys %postfix_native_mailbox_map ); + %info = ( 'svc' => 'svc_acct', 'desc' => 'Real-time export of accounts to SQL databases '. @@ -94,13 +109,21 @@ to be configured for different mail server setups. this.form.schema.value = "$postfix_courierimap_alias_map"; this.form.primary_key.value = "address"; '> + <LI><INPUT TYPE="button" VALUE="postfix_native_mailbox" onClick=' + this.form.table.value = "users"; + this.form.schema.value = "$postfix_native_mailbox_map"; + this.form.primary_key.value = "userid"; + '> </UL> END ); +sub _schema_map { shift->_map('schema'); } +sub _static_map { shift->_map('static'); } + sub _map { my $self = shift; - map { /^\s*(\S+)\s*(\S+)\s*$/ } split("\n", $self->option('schema') ); + map { /^\s*(\S+)\s*(\S+)\s*$/ } split("\n", $self->option(shift) ); } sub rebless { shift; } @@ -108,14 +131,22 @@ sub rebless { shift; } sub _export_insert { my($self, $svc_acct) = (shift, shift); - my %map = $self->_map; + my %schema = $self->_schema_map; + my %static = $self->_static_map; - my %record = map { my $value = $map{$_}; - my @arg = (); - push @arg, $self->option('crypt') - if $value eq 'crypt_password' && $self->option('crypt'); - $_ => $svc_acct->$value(@arg); - } keys %map; + my %record = ( + + ( map { $_ => $static{$_} } keys %static ), + + ( map { my $value = $schema{$_}; + my @arg = (); + push @arg, $self->option('crypt') + if $value eq 'crypt_password' && $self->option('crypt'); + $_ => $svc_acct->$value(@arg); + } keys %schema + ), + + ); my $err_or_queue = $self->acct_sql_queue( @@ -133,25 +164,33 @@ sub _export_insert { sub _export_replace { my($self, $new, $old) = (shift, shift, shift); - my %map = $self->_map; + my %schema = $self->_schema_map; + my %static = $self->_static_map; my @primary_key = (); if ( $self->option('primary_key') =~ /,/ ) { foreach my $key ( split(/\s*,\s*/, $self->option('primary_key') ) ) { - my $keymap = $map{$key}; + my $keymap = $schema{$key}; push @primary_key, $old->$keymap(); } } else { - my $keymap = $map{$self->option('primary_key')}; + my $keymap = $schema{$self->option('primary_key')}; push @primary_key, $old->$keymap(); } - my %record = map { my $value = $map{$_}; - my @arg = (); - push @arg, $self->option('crypt') - if $value eq 'crypt_password' && $self->option('crypt'); - $_ => $new->$value(@arg); - } keys %map; + my %record = ( + + ( map { $_ => $static{$_} } keys %static ), + + ( map { my $value = $schema{$_}; + my @arg = (); + push @arg, $self->option('crypt') + if $value eq 'crypt_password' && $self->option('crypt'); + $_ => $new->$value(@arg); + } keys %schema + ), + + ); my $err_or_queue = $self->acct_sql_queue( $new->svcnum, @@ -167,16 +206,16 @@ sub _export_replace { sub _export_delete { my ( $self, $svc_acct ) = (shift, shift); - my %map = $self->_map; + my %schema = $self->_schema_map; my %primary_key = (); if ( $self->option('primary_key') =~ /,/ ) { foreach my $key ( split(/\s*,\s*/, $self->option('primary_key') ) ) { - my $keymap = $map{$key}; + my $keymap = $schema{$key}; $primary_key{ $key } = $svc_acct->$keymap(); } } else { - my $keymap = $map{$self->option('primary_key')}; + my $keymap = $schema{$self->option('primary_key')}; $primary_key{ $self->option('primary_key') } = $svc_acct->$keymap(), } diff --git a/FS/FS/part_export/communigate_pro_singledomain.pm b/FS/FS/part_export/communigate_pro_singledomain.pm index 6a1bf60eb..e25043fbb 100644 --- a/FS/FS/part_export/communigate_pro_singledomain.pm +++ b/FS/FS/part_export/communigate_pro_singledomain.pm @@ -20,7 +20,7 @@ tie my %options, 'Tie::IxHash', %FS::part_export::communigate_pro::options, Real time export to a <a href="http://www.stalker.com/CommuniGatePro/">CommuniGate Pro</a> mail server. This is an unusual export to CommuniGate Pro that forces all -accounts into a single domain. As CommuniGate Pro supports multipledomains, +accounts into a single domain. As CommuniGate Pro supports multiple domains, unless you have a specific reason for using this export, you probably want to use the communigate_pro export instead. The <a href="http://www.stalker.com/CGPerl/">CommuniGate Pro Perl Interface</a> diff --git a/FS/FS/part_export/domain_shellcommands.pm b/FS/FS/part_export/domain_shellcommands.pm index d15f41a84..994c113bf 100644 --- a/FS/FS/part_export/domain_shellcommands.pm +++ b/FS/FS/part_export/domain_shellcommands.pm @@ -112,19 +112,22 @@ sub _export_replace { ( $old_qdomain = $old_domain ) =~ s/\./:/g; #see dot-qmail(5): EXTENSION ADDRESSES ( $new_qdomain = $new_domain ) =~ s/\./:/g; #see dot-qmail(5): EXTENSION ADDRESSES - if ( $old->catchall ) { + { no strict 'refs'; - my $svc_acct = $old->catchall_svc_acct; - ${"old_$_"} = $svc_acct->getfield($_) foreach qw(uid gid dir); - } else { - ${"old_$_"} = '' foreach qw(uid gid dir); - } - if ( $new->catchall ) { - no strict 'refs'; - my $svc_acct = $new->catchall_svc_acct; - ${"new_$_"} = $svc_acct->getfield($_) foreach qw(uid gid dir); - } else { - ${"new_$_"} = '' foreach qw(uid gid dir); + + if ( $old->catchall ) { + my $svc_acct = $old->catchall_svc_acct; + ${"old_$_"} = $svc_acct->getfield($_) foreach qw(uid gid dir); + } else { + ${"old_$_"} = '' foreach qw(uid gid dir); + } + if ( $new->catchall ) { + my $svc_acct = $new->catchall_svc_acct; + ${"new_$_"} = $svc_acct->getfield($_) foreach qw(uid gid dir); + } else { + ${"new_$_"} = '' foreach qw(uid gid dir); + } + } #done setting variables for the command diff --git a/FS/FS/part_export/domain_sql.pm b/FS/FS/part_export/domain_sql.pm new file mode 100644 index 000000000..0ce1b16e3 --- /dev/null +++ b/FS/FS/part_export/domain_sql.pm @@ -0,0 +1,238 @@ +package FS::part_export::domain_sql; + +use vars qw(@ISA %info); +use Tie::IxHash; +use FS::part_export; + +@ISA = qw(FS::part_export); + +#quite a bit of false laziness w/acct_sql - some stuff should be generalized +#out to a "dababase base class" + +tie my %options, 'Tie::IxHash', + 'datasrc' => { label => 'DBI data source' }, + 'username' => { label => 'Database username' }, + 'password' => { label => 'Database password' }, + 'table' => { label => 'Database table' }, + 'schema' => { label => + 'Database schema mapping to Freeside methods.', + type => 'textarea', + }, + 'static' => { label => + 'Database schema mapping to static values.', + type => 'textarea', + }, + 'primary_key' => { label => 'Database primary key' }, +; + +tie my %postfix_transport_map, 'Tie::IxHash', + 'domain' => 'domain' +; +my $postfix_transport_map = + join('\n', map "$_ $postfix_transport_map{$_}", + keys %postfix_transport_map ); +tie my %postfix_transport_static, 'Tie::IxHash', + 'transport' => 'virtual:', +; +my $postfix_transport_static = + join('\n', map "$_ $postfix_transport_static{$_}", + keys %postfix_transport_static ); + +%info = ( + 'svc' => 'svc_domain', + 'desc' => 'Real time export of domains to SQL databases '. + '(postfix, others?)', + 'options' => \%options, + 'notes' => <<END +Export domains (svc_domain records) to SQL databases. Currently this is a +simple export with a default for Postfix, but it can be extended for other +uses. + +<BR><BR>Use these buttons for useful presets: +<UL> + <LI><INPUT TYPE="button" VALUE="postfix_transport" onClick=' + this.form.table.value = "transport"; + this.form.schema.value = "$postfix_transport_map"; + this.form.static.value = "$postfix_transport_static"; + this.form.primary_key.value = "domain"; + '> +</UL> +END +); + +sub _schema_map { shift->_map('schema'); } +sub _static_map { shift->_map('static'); } + +sub _map { + my $self = shift; + map { /^\s*(\S+)\s*(\S+)\s*$/ } split("\n", $self->option(shift) ); +} + +sub _export_insert { + my($self, $svc_domain) = (shift, shift); + + my %schema = $self->_schema_map; + my %static = $self->_static_map; + + my %record = ( ( map { $_ => $static{$_} } keys %static ), + ( map { my $method = $schema{$_}; + $_ => $svc_domain->$method(); + } + keys %schema + ) + ); + + my $err_or_queue = + $self->domain_sql_queue( + $svc_domain->svcnum, + 'insert', + $self->option('table'), + %record + ); + return $err_or_queue unless ref($err_or_queue); + + ''; +} + +sub _export_replace { + my($self, $new, $old) = (shift, shift, shift); + + my %schema = $self->_schema_map; + my %static = $self->_static_map; + + my @primary_key = (); + if ( $self->option('primary_key') =~ /,/ ) { + foreach my $key ( split(/\s*,\s*/, $self->option('primary_key') ) ) { + my $keymap = $schema{$key}; + push @primary_key, $old->$keymap(); + } + } else { + my $keymap = $map{$self->option('primary_key')}; + push @primary_key, $old->$keymap(); + } + + my %record = ( ( map { $_ => $static{$_} } keys %static ), + ( map { my $method = $schema{$_}; + $_ => $new->$method(); + } + keys %schema + ) + ); + + my $err_or_queue = $self->domain_sql_queue( + $new->svcnum, + 'replace', + $self->option('table'), + $self->option('primary_key'), @primary_key, + %record, + ); + return $err_or_queue unless ref($err_or_queue); + ''; +} + +sub _export_delete { + my ( $self, $svc_domain ) = (shift, shift); + + my %schema = $self->_schema_map; + my %static = $self->_static_map; + + my %primary_key = (); + if ( $self->option('primary_key') =~ /,/ ) { + foreach my $key ( split(/\s*,\s*/, $self->option('primary_key') ) ) { + my $keymap = $map{$key}; + $primary_key{ $key } = $svc_domain->$keymap(); + } + } else { + my $keymap = $map{$self->option('primary_key')}; + $primary_key{ $self->option('primary_key') } = $svc_domain->$keymap(), + } + + my $err_or_queue = $self->domain_sql_queue( + $svc_domain->svcnum, + 'delete', + $self->option('table'), + %primary_key, + #$self->option('primary_key') => $svc_domain->$keymap(), + ); + return $err_or_queue unless ref($err_or_queue); + ''; +} + +sub domain_sql_queue { + my( $self, $svcnum, $method ) = (shift, shift, shift); + my $queue = new FS::queue { + 'svcnum' => $svcnum, + 'job' => "FS::part_export::domain_sql::domain_sql_$method", + }; + $queue->insert( + $self->option('datasrc'), + $self->option('username'), + $self->option('password'), + @_, + ) or $queue; +} + +sub domain_sql_insert { #subroutine, not method + my $dbh = domain_sql_connect(shift, shift, shift); + my( $table, %record ) = @_; + + my $sth = $dbh->prepare( + "INSERT INTO $table ( ". join(", ", keys %record). + " ) VALUES ( ". join(", ", map '?', keys %record ). " )" + ) or die $dbh->errstr; + + $sth->execute( values(%record) ) + or die "can't insert into $table table: ". $sth->errstr; + + $dbh->disconnect; +} + +sub domain_sql_delete { #subroutine, not method + my $dbh = domain_sql_connect(shift, shift, shift); + my( $table, %record ) = @_; + + my $sth = $dbh->prepare( + "DELETE FROM $table WHERE ". join(' AND ', map "$_ = ? ", keys %record ) + ) or die $dbh->errstr; + + $sth->execute( map $record{$_}, keys %record ) + or die "can't delete from $table table: ". $sth->errstr; + + $dbh->disconnect; +} + +sub domain_sql_replace { #subroutine, not method + my $dbh = domain_sql_connect(shift, shift, shift); + + my( $table, $pkey ) = ( shift, shift ); + + my %primary_key = (); + if ( $pkey =~ /,/ ) { + foreach my $key ( split(/\s*,\s*/, $pkey ) ) { + $primary_key{$key} = shift; + } + } else { + $primary_key{$pkey} = shift; + } + + my %record = @_; + + my $sth = $dbh->prepare( + "UPDATE $table". + ' SET '. join(', ', map "$_ = ?", keys %record ). + ' WHERE '. join(' AND ', map "$_ = ?", keys %primary_key ) + ) or die $dbh->errstr; + + $sth->execute( values(%record), values(%primary_key) ); + + $dbh->disconnect; +} + +sub domain_sql_connect { + #my($datasrc, $username, $password) = @_; + #DBI->connect($datasrc, $username, $password) or die $DBI::errstr; + DBI->connect(@_) or die $DBI::errstr; +} + +1; + diff --git a/FS/FS/part_export/nas_wrapper.pm b/FS/FS/part_export/nas_wrapper.pm new file mode 100644 index 000000000..fee9f48fe --- /dev/null +++ b/FS/FS/part_export/nas_wrapper.pm @@ -0,0 +1,310 @@ +package FS::part_export::nas_wrapper; + +=head1 FS::part_export::nas_wrapper + +This is a meta-export that triggers other exports for FS::svc_broadband objects +based on a set of configurable conditions. These conditions are defined by the +following FS::router virtual fields: + +=over 4 + +=item nas_conf - Per-router meta-export configuration. See L</"nas_conf Syntax">. + +=back + +=head2 nas_conf Syntax + +export_name|routernum[,routernum]|[field,condition[,field,condition]][||...] + +=over 4 + +=item export_name - Name or exportnum of the export to be executed. In order to specify export options you must use the exportnum form. (ex. 'router' for FS::part_export::router). + +=item routernum - FS::router routernum corresponding to the desired FS::router for which this export will be run. + +=item field - FS::svc_broadband field (real or virtual). The following condition (regex) will be matched against the value of this field. + +=item condition - A regular expression to be match against the value of the previously listed FS::svc_broadband field. + +=back + +If multiple routernum's are specified, then the export will be triggered for each router listed. If multiple field/condition pairs are present, then the results of the matches will be and'd. Note that if a false match is found, the rest of the matches may not be checked. + +You can specify multiple export/router/condition sets by concatenating them with '||'. + +=cut + +use strict; +use vars qw(@ISA %info $me $DEBUG); + +use FS::Record qw(qsearchs); +use FS::part_export; + +use Tie::IxHash; +use Data::Dumper qw(Dumper); + +@ISA = qw(FS::part_export); +$me = '[' . __PACKAGE__ . ']'; +$DEBUG = 1; + +%info = ( + 'svc' => 'svc_broadband', + 'desc' => 'A meta-export that triggers other svc_broadband exports.', + 'options' => {}, + 'notes' => '', +); + + +sub rebless { shift; } + +sub _export_insert { + my($self) = shift; + $self->_export_command('insert', @_); +} + +sub _export_delete { + my($self) = shift; + $self->_export_command('delete', @_); +} + +sub _export_suspend { + my($self) = shift; + $self->_export_command('suspend', @_); +} + +sub _export_unsuspend { + my($self) = shift; + $self->_export_command('unsuspend', @_); +} + +sub _export_replace { + my($self) = shift; + $self->_export_command('replace', @_); +} + +sub _export_command { + my ( $self, $action, $svc_broadband) = (shift, shift, shift); + + my ($new, $old); + if ($action eq 'replace') { + $new = $svc_broadband; + $old = shift; + } + + my $router = $svc_broadband->addr_block->router; + + return '' unless grep(/^nas_conf$/, $router->fields); + my $nas_conf = $router->nas_conf; + + my $child_exports = &_parse_nas_conf($nas_conf); + + my $error = ''; + + my $queue_child_exports = {}; + + # Similar to FS::svc_Common::replace, calling insert, delete, and replace + # exports where necessary depending on which conditions match. + if ($action eq 'replace') { + + my @new_child_exports = (); + my @old_child_exports = (); + + # Find all the matching "new" child exports. + foreach my $child_export (@$child_exports) { + my $match = &_test_child_export_conditions( + $child_export->{'conditions'}, + $new, + ); + + if ($match) { + push @new_child_exports, $child_export; + } + } + + # Find all the matching "old" child exports. + foreach my $child_export (@$child_exports) { + my $match = &_test_child_export_conditions( + $child_export->{'conditions'}, + $old, + ); + + if ($match) { + push @old_child_exports, $child_export; + } + } + + # Insert exports for new. + push @{$queue_child_exports->{'insert'}}, ( + map { + my $new_child_export = $_; + if (! grep { $new_child_export eq $_ } @old_child_exports) { + $new_child_export->{'args'} = [ $new ]; + $new_child_export; + } else { + (); + } + } @new_child_exports + ); + + # Replace exports for new and old. + push @{$queue_child_exports->{'replace'}}, ( + map { + my $new_child_export = $_; + if (grep { $new_child_export eq $_ } @old_child_exports) { + $new_child_export->{'args'} = [ $new, $old ]; + $new_child_export; + } else { + (); + } + } @new_child_exports + ); + + # Delete exports for old. + push @{$queue_child_exports->{'delete'}}, ( + grep { + my $old_child_export = $_; + if (! grep { $old_child_export eq $_ } @new_child_exports) { + $old_child_export->{'args'} = [ $old ]; + $old_child_export; + } else { + (); + } + } @old_child_exports + ); + + } else { + + foreach my $child_export (@$child_exports) { + my $match = &_test_child_export_conditions( + $child_export->{'conditions'}, + $svc_broadband, + ); + + if ($match) { + $child_export->{'args'} = [ $svc_broadband ]; + push @{$queue_child_exports->{$action}}, $child_export; + } + } + + } + + warn "[debug]$me Dispatching child exports... " + . &Dumper($queue_child_exports); + + # Actually call the child exports now, with their preset action and arguments. + foreach my $_action (keys(%$queue_child_exports)) { + + foreach my $_child_export (@{$queue_child_exports->{$_action}}) { + $error = &_dispatch_child_export( + $_child_export, + $_action, + @{$_child_export->{'args'}}, + ); + + # Bail if there's an error queueing one of the exports. + # This will all get rolled-back. + return $error if $error; + } + + } + + return ''; + +} + + +sub _parse_nas_conf { + + my $nas_conf = shift; + my @child_exports = (); + + foreach my $cond_set ($nas_conf =~ m/(.*?[^\\])(?:\|\||$)/g) { + + warn "[debug]$me cond_set is '$cond_set'" if $DEBUG; + + my @args = $cond_set =~ m/(.*?[^\\])(?:\||$)/g; + + my %child_export = ( + 'export' => $args[0], + 'routernum' => [ split(/,\s*/, $args[1]) ], + 'conditions' => { @args[2..$#args] }, + ); + + warn "[debug]$me " . Dumper(\%child_export) if $DEBUG; + + push @child_exports, { %child_export }; + + } + + return \@child_exports; + +} + +sub _dispatch_child_export { + + my ($child_export, $action, @args) = (shift, shift, @_); + + my $child_export_name = $child_export->{'export'}; + my @routernums = @{$child_export->{'routernum'}}; + + my $error = ''; + + # And the real hack begins... + + my $child_part_export; + if ($child_export_name =~ /^(\d+)$/) { + my $exportnum = $1; + $child_part_export = qsearchs('part_export', { exportnum => $exportnum }); + unless ($child_part_export) { + return "No such FS::part_export with exportnum '$exportnum'"; + } + + $child_export_name = $child_part_export->exporttype; + } else { + $child_part_export = new FS::part_export { + 'exporttype' => $child_export_name, + 'machine' => 'bogus', + }; + } + + warn "[debug]$me running export '$child_export_name' for routernum(s) '" + . join(',', @routernums) . "'" if $DEBUG; + + my $cmd_method = "_export_$action"; + + foreach my $routernum (@routernums) { + $error ||= $child_part_export->$cmd_method( + @args, + 'routernum' => $routernum, + ); + last if $error; + } + + warn "[debug]$me export '$child_export_name' returned '$error'" + if $DEBUG; + + return $error; + +} + +sub _test_child_export_conditions { + + my ($conditions, $svc_broadband) = (shift, shift); + + my $match = 1; + foreach my $cond_field (keys %$conditions) { + my $cond_regex = $conditions->{$cond_field}; + warn "[debug]$me Condition: $cond_field =~ /$cond_regex/" if $DEBUG; + unless ($svc_broadband->get($cond_field) =~ /$cond_regex/) { + $match = 0; + last; + } + } + + return $match; + +} + + +1; + diff --git a/FS/FS/part_export/prizm.pm b/FS/FS/part_export/prizm.pm new file mode 100644 index 000000000..711888d1f --- /dev/null +++ b/FS/FS/part_export/prizm.pm @@ -0,0 +1,361 @@ +package FS::part_export::prizm; + +use vars qw(@ISA %info %options $DEBUG); +use Tie::IxHash; +use FS::Record qw(fields); +use FS::part_export; + +@ISA = qw(FS::part_export); +$DEBUG = 1; + +tie %options, 'Tie::IxHash', + 'url' => { label => 'Northbound url', default=>'https://localhost:8443/prizm/nbi' }, + 'user' => { label => 'Northbound username', default=>'nbi' }, + 'password' => { label => 'Password', default => '' }, +; + +%info = ( + 'svc' => 'svc_broadband', + 'desc' => 'Real-time export to Northbound Interface', + 'options' => \%options, + 'nodomain' => 'Y', + 'notes' => 'These are notes.' +); + +sub prizm_command { + my ($self,$namespace,$method) = (shift,shift,shift); + + eval "use Net::Prizm qw(CustomerInfo PrizmElement);"; + die $@ if $@; + + my $prizm = new Net::Prizm ( + namespace => $namespace, + url => $self->option('url'), + user => $self->option('user'), + password => $self->option('password'), + ); + + $prizm->$method(@_); +} + +sub _export_insert { + my( $self, $svc ) = ( shift, shift ); + + my $cust_main = $svc->cust_svc->cust_pkg->cust_main; + + my $err_or_som = $self->prizm_command(CustomerIfService, 'getCustomers', + ['import_id'], + [$cust_main->custnum], + ['='], + ); + return $err_or_som + unless ref($err_or_som); + + my $pre = ''; + if ( defined $cust_main->dbdef_table->column('ship_last') ) { + $pre = $cust_main->ship_last ? 'ship_' : ''; + } + my $name = $pre ? $cust_main->ship_name : $cust_main->name; + my $location = join(" ", map { my $method = "$pre$_"; $cust_main->$method } + qw (address1 address2 city state zip) + ); + my $contact = join(" ", map { my $method = "$pre$_"; $cust_main->$method } + qw (daytime night) + ); + + my $pcustomer; + if ($err_or_som->result->[0]) { + $pcustomer = $err_or_som->result->[0]->customerId; + }else{ + my $chashref = $cust_main->hashref; + my $customerinfo = { + importId => $cust_main->custnum, + customerName => $name, + customerType => 'freeside', + address1 => $chashref->{"${pre}address1"}, + address2 => $chashref->{"${pre}address2"}, + city => $chashref->{"${pre}city"}, + state => $chashref->{"${pre}state"}, + zipCode => $chashref->{"${pre}zip"}, + workPhone => $chashref->{"${pre}daytime"}, + homePhone => $chashref->{"${pre}night"}, + email => @{[$cust_main->invoicing_list_emailonly]}[0], + extraFieldNames => [ 'country', 'freesideId', + ], + extraFieldValues => [ $chashref->{"${pre}country"}, $cust_main->custnum, + ], + }; + + $err_or_som = $self->prizm_command('CustomerIfService', 'addCustomer', + $customerinfo); + return $err_or_som + unless ref($err_or_som); + + $pcustomer = $err_or_som->result; + } + warn "multiple prizm customers found for $cust_main->custnum" + if scalar(@$pcustomer) > 1; + + #kinda big question/expensive + $err_or_som = $self->prizm_command('NetworkIfService', 'getPrizmElements', + ['Network Default Gateway Address'], + [$svc->addr_block->ip_gateway], + ['='], + ); + return $err_or_som + unless ref($err_or_som); + + return "No elements in network" unless exists $err_or_som->result->[0]; + + my $networkid = 0; + for (my $i = 0; $i < $err_or_som->result->[0]->attributeNames; $i++) { + if ($err_or_som->result->[0]->attributeNames->[$i] eq "Network.ID"){ + $networkid = $err_or_som->result->[0]->attributeValues->[$i]; + last; + } + } + + $err_or_som = $self->prizm_command('NetworkIfService', 'addProvisionedElement', + $networkid, + $svc->mac_addr, + $name . " " . $svc->description, + $location, + $contact, + sprintf("%032X", $svc->authkey), + $svc->cust_svc->cust_pkg->part_pkg->pkg, + $svc->vlan_profile, + 1, + ); + return $err_or_som + unless ref($err_or_som); + + my (@names) = ('Management IP', + 'GPS Latitude', + 'GPS Longitude', + 'GPS Altitude', + 'Site Name', + 'Site Location', + 'Site Contact', + ); + my (@values) = ($svc->ip_addr, + $svc->latitude, + $svc->longitude, + $svc->altitude, + $name, + $location, + $contact, + ); + $element = $err_or_som->result->elementId; + $err_or_som = $self->prizm_command('NetworkIfService', 'setElementConfig', + [ $element ], + \@names, + \@values, + 0, + 1, + ); + return $err_or_som + unless ref($err_or_som); + + $err_or_som = $self->prizm_command('NetworkIfService', 'setElementConfigSet', + [ $element ], + $svc->vlan_profile, + 0, + 1, + ); + return $err_or_som + unless ref($err_or_som); + + $err_or_som = $self->prizm_command('NetworkIfService', 'setElementConfigSet', + [ $element ], + $svc->cust_svc->cust_pkg->part_pkg->pkg, + 0, + 1, + ); + return $err_or_som + unless ref($err_or_som); + + $err_or_som = $self->prizm_command('NetworkIfService', + 'activateNetworkElements', + [ $element ], + 1, + 1, + ); + + return $err_or_som + unless ref($err_or_som); + + $err_or_som = $self->prizm_command('CustomerIfService', + 'addElementToCustomer', + 0, + $cust_main->custnum, + 0, + $svc->mac_addr, + ); + + return $err_or_som + unless ref($err_or_som); + + ''; +} + +sub _export_delete { + my( $self, $svc ) = ( shift, shift ); + + my $custnum = $svc->cust_svc->cust_pkg->cust_main->custnum; + + my $err_or_som = $self->prizm_command('NetworkIfService', 'getPrizmElements', + ['MAC Address'], + [$svc->mac_addr], + ['='], + ); + return $err_or_som + unless ref($err_or_som); + + return "Can't find prizm element for " . $svc->mac_addr + unless $err_or_som->result->[0]; + + $err_or_som = $self->prizm_command('NetworkIfService', + 'suspendNetworkElements', + [$err_or_som->result->[0]->elementId], + 1, + 1, + ); + + return $err_or_som + unless ref($err_or_som); + + $err_or_som = $self->prizm_command('CustomerIfService', + 'removeElementFromCustomer', + 0, + $custnum, + 0, + $svc->mac_addr, + ); + + return $err_or_som + unless ref($err_or_som); + + ''; +} + +sub _export_replace { + my( $self, $new, $old ) = ( shift, shift, shift ); + + my $err_or_som = $self->prizm_command('NetworkIfService', 'getPrizmElements', + [ 'MAC Address' ], + [ $old->mac_addr ], + [ '=' ], + ); + return $err_or_som + unless ref($err_or_som); + + return "Can't find prizm element for " . $old->mac_addr + unless $err_or_som->result->[0]; + + my %freeside2prizm = ( mac_addr => 'MAC Address', + ip_addr => 'Management IP', + latitude => 'GPS Latitude', + longitude => 'GPS Longitude', + altitude => 'GPS Altitude', + authkey => 'Authentication Key', + ); + + my (@values); + my (@names) = map { push @values, $new->$_; $freeside2prizm{$_} } + grep { $old->$_ ne $new->$_ } + grep { exists($freeside2prizm{$_}) } + fields( 'svc_broadband' ); + + if ($old->description ne $new->description) { + my $cust_main = $old->cust_svc->cust_pkg->cust_main; + my $name = defined($cust_main->dbdef_table->column('ship_last')) + ? $cust_main->ship_name + : $cust_main->name; + push @values, $name . " " . $new->description; + push @names, "Site Name"; + } + + my $element = $err_or_som->result->[0]->elementId; + + $err_or_som = $self->prizm_command('NetworkIfService', 'setElementConfig', + [ $element ], + \@names, + \@values, + 0, + 1, + ); + return $err_or_som + unless ref($err_or_som); + + $err_or_som = $self->prizm_command('NetworkIfService', 'setElementConfigSet', + [ $element ], + $new->vlan_profile, + 0, + 1, + ) + if $old->vlan_profile ne $new->vlan_profile; + + return $err_or_som + unless ref($err_or_som); + + ''; + +} + +sub _export_suspend { + my( $self, $svc ) = ( shift, shift ); + + my $err_or_som = $self->prizm_command('NetworkIfService', 'getPrizmElements', + [ 'MAC Address' ], + [ $svc->mac_addr ], + [ '=' ], + ); + return $err_or_som + unless ref($err_or_som); + + return "Can't find prizm element for " . $svc->mac_addr + unless $err_or_som->result->[0]; + + $err_or_som = $self->prizm_command('NetworkIfService', + 'suspendNetworkElements', + [ $err_or_som->result->[0]->elementId ], + 1, + 1, + ); + + return $err_or_som + unless ref($err_or_som); + + ''; + +} + +sub _export_unsuspend { + my( $self, $svc ) = ( shift, shift ); + + my $err_or_som = $self->prizm_command('NetworkIfService', 'getPrizmElements', + [ 'MAC Address' ], + [ $svc->mac_addr ], + [ '=' ], + ); + return $err_or_som + unless ref($err_or_som); + + return "Can't find prizm element for " . $svc->mac_addr + unless $err_or_som->result->[0]; + + $err_or_som = $self->prizm_command('NetworkIfService', + 'activateNetworkElements', + [ $err_or_som->result->[0]->elementId ], + 1, + 1, + ); + + return $err_or_som + unless ref($err_or_som); + + ''; + +} + +1; diff --git a/FS/FS/part_export/router.pm b/FS/FS/part_export/router.pm index 648a4372b..e14b57932 100644 --- a/FS/FS/part_export/router.pm +++ b/FS/FS/part_export/router.pm @@ -5,35 +5,47 @@ package FS::part_export::router; This export connects to a router and transmits commands via telnet or SSH. It requires the following custom router fields: +=head1 Required custom fields + =over 4 -=item admin_address - IP address (or hostname) to connect +=item admin_address - IP address (or hostname) to connect. -=item admin_user - username for admin access +=item admin_user - Username for the router. -=item admin_password - password for admin access +=item admin_password - Password for the router. -=back +=item admin_protocol - Protocol to use for the router. 'telnet' or 'ssh'. The ssh protocol only support password-less (ie. RSA key) authentication. As such, the admin_password field isn't used if ssh is specified. -The export itself needs the following options: +=item admin_timeout - Time in seconds to wait for a connection. -=over 4 +=item admin_prompt - A regular expression matching the router's prompt. See Net::Telnet for details. Only applies to the 'telnet' protocol. + +=item admin_cmd_insert - Insert export command. See below. -=item insert, replace, delete - command strings (to be interpolated) +=item admin_cmd_delete - Delete export command. See below. -=item Prompt - prompt string to expect from router after successful login +=item admin_cmd_replace - Replace export command. See below. -=item Timeout - time to wait for prompt string +=item admin_cmd_suspend - Suspend export command. See below. + +=item admin_cmd_unsuspend - Unsuspend export command. See below. + +The admin_cmd_* virtual fields, if set, will be double quoted, eval'd, and executed on the router specified. + +If any of the required router virtual fields are not defined, then the export silently declines. =back -(Prompt and Timeout are required only for telnet connections.) +The export itself takes no options. =cut -use vars qw(@ISA %info @saltset); +use strict; +use vars qw(@ISA %info $me $DEBUG); use Tie::IxHash; use String::ShellQuote; +use FS::Record qw(qsearchs); use FS::part_export; @ISA = qw(FS::part_export); @@ -44,26 +56,32 @@ tie my %options, 'Tie::IxHash', type =>'select', options => [qw(telnet ssh)], default => 'telnet'}, - 'insert' => {label=>'Insert command', default=>'' }, - 'delete' => {label=>'Delete command', default=>'' }, - 'replace' => {label=>'Replace command', default=>'' }, - 'Timeout' => {label=>'Time to wait for prompt', default=>'20' }, - 'Prompt' => {label=>'Prompt string', default=>'#' } ; %info = ( 'svc' => 'svc_broadband', 'desc' => 'Send a command to a router.', 'options' => \%options, - 'notes' => 'Installation of Net::Telnet from CPAN is required for telnet connections. ( more detailed description from Kristian / fire2wire? )', + 'notes' => 'Installation of Net::Telnet from CPAN is required for telnet connections. This export will execute if the following virtual fields are set on the router: admin_user, admin_password, admin_address, admin_timeout, admin_prompt. Option virtual fields are: admin_cmd_insert, admin_cmd_replace, admin_cmd_delete, admin_cmd_suspend, admin_cmd_unsuspend.', ); -@saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' ); +$me = '[' . __PACKAGE__ . ']'; +$DEBUG = 1; + sub rebless { shift; } +sub _field_prefix { 'admin'; } + +sub _req_router_fields { + map { + $_[0]->_field_prefix . '_' . $_ + } (qw(address prompt user)); +} + sub _export_insert { my($self) = shift; + warn "Running insert for " . ref($self); $self->_export_command('insert', @_); } @@ -82,83 +100,159 @@ sub _export_unsuspend { $self->_export_command('unsuspend', @_); } -sub _export_command { - my ( $self, $action, $svc_broadband) = (shift, shift, shift); - my $command = $self->option($action); - return '' if $command =~ /^\s*$/; +sub _export_replace { + my($self) = shift; + $self->_export_command('replace', @_); +} - no strict 'vars'; - { - no strict 'refs'; - ${$_} = $svc_broadband->getfield($_) foreach $svc_broadband->fields; +sub _export_command { + my ($self, $action, $svc_broadband) = (shift, shift, shift); + my ($error, $old); + + if ($action eq 'replace') { + $old = shift; } + + warn "[debug]$me Processing action '$action'" if $DEBUG; + # fetch router info - my $router = $svc_broadband->addr_block->router; - my %r; - $r{$_} = $router->getfield($_) foreach $router->virtual_fields; - #warn qq("$command"); - #warn eval(qq("$command")); - - warn "admin_address: '$r{admin_address}'"; - - if ($r{admin_address} ne '') { - $self->router_queue( $svc_broadband->svcnum, $self->option('protocol'), - user => $r{admin_user}, - password => $r{admin_password}, - host => $r{admin_address}, - Timeout => $self->option('Timeout'), - Prompt => $self->option('Prompt'), - command => eval(qq("$command")), - ); - } else { + my $router = $self->_get_router($svc_broadband, @_); + unless ($router) { + return "Unable to lookup router for $action export"; + } + + unless ($self->_check_router_fields($router)) { + # Virtual fields aren't defined. Exit silently. + warn "[debug]$me Required router virtual fields not defined. Returning..."; return ''; } + + my $args; + ($error, $args) = $self->_prepare_args( + $action, + $router, + $svc_broadband, + ($old ? $old : ()), + @_ + ); + + if ($error) { + # Error occured while preparing args. + return $error; + } elsif (not defined $args) { + # Silently decline. + warn "[debug]$me Declining '$action' export"; + return ''; + } # else ... queue the export. + + warn "[debug]$me Queueing with args: " . join(', ', @$args) if $DEBUG; + + return( + $self->_queue( + $svc_broadband->svcnum, + $self->_get_cmd_sub($svc_broadband, $router), + @$args + ) + ); + } -sub _export_replace { +sub _prepare_args { - # We don't handle the case of a svc_broadband moving between routers. - # If you want to do that, reprovision the service. + my ($self, $action, $router, $svc_broadband) = (shift, shift, shift, shift); + my $old = shift if ($action eq 'replace'); + + my $field_prefix = $self->_field_prefix; + my $command = $router->getfield("${field_prefix}_cmd_${action}"); + unless ($command) { + warn "[debug]$me router custom field '${field_prefix}_cmd_$action' " + . "is not defined." if $DEBUG; + return ''; + } - my($self, $new, $old ) = (shift, shift, shift); - my $command = $self->option('replace'); - no strict 'vars'; { + no strict 'vars'; no strict 'refs'; - ${"old_$_"} = $old->getfield($_) foreach $old->fields; - ${"new_$_"} = $new->getfield($_) foreach $new->fields; + + if ($action eq 'replace') { + ${"old_$_"} = $old->getfield($_) foreach $old->fields; + ${"new_$_"} = $svc_broadband->getfield($_) foreach $svc_broadband->fields; + $command = eval(qq("$command")); + } else { + ${$_} = $svc_broadband->getfield($_) foreach $svc_broadband->fields; + $command = eval(qq("$command")); + } + return $@ if $@; } - my $router = $new->addr_block->router; - my %r; - $r{$_} = $router->getfield($_) foreach $router->virtual_fields; - - if ($r{admin_address} ne '') { - $self->router_queue( $new->svcnum, $self->option('protocol'), - user => $r{admin_user}, - password => $r{admin_password}, - host => $r{admin_address}, - Timeout => $self->option('Timeout'), - Prompt => $self->option('Prompt'), - command => eval(qq("$command")), - ); - } else { - return ''; + my $args = [ + 'user' => $router->getfield($field_prefix . '_user'), + 'password' => $router->getfield($field_prefix . '_password'), + 'host' => $router->getfield($field_prefix . '_address'), + 'Timeout' => $router->getfield($field_prefix . '_timeout'), + 'Prompt' => $router->getfield($field_prefix . '_prompt'), + 'command' => $command, + ]; + + return('', $args); + +} + +sub _get_cmd_sub { + + my ($self, $svc_broadband, $router) = (shift, shift, shift); + + my $protocol = ( + $router->getfield($self->_field_prefix . '_protocol') =~ /^(telnet|ssh)$/ + ) ? $1 : 'telnet'; + + return(ref($self)."::".$protocol."_cmd"); + +} + +sub _check_router_fields { + + my ($self, $router, $action) = (shift, shift, shift); + my @check_fields = $self->_req_router_fields; + + foreach (@check_fields) { + if ($router->getfield($_) eq '') { + warn "[debug]$me Required field '$_' is unset"; + return 0; + } else { + return 1; + } } + } -#a good idea to queue anything that could fail or take any time -sub router_queue { +sub _queue { #warn join ':', @_; - my( $self, $svcnum, $protocol ) = (shift, shift, shift); + my( $self, $svcnum, $cmd_sub ) = (shift, shift, shift); my $queue = new FS::queue { 'svcnum' => $svcnum, }; - $queue->job ("FS::part_export::router::".$protocol."_cmd"); - $queue->insert( @_ ); + $queue->job($cmd_sub); + $queue->insert(@_); +} + +sub _get_router { + my ($self, $svc_broadband, %args) = (shift, shift, shift, @_); + + my $router; + if ($args{'routernum'}) { + $router = qsearchs('router', { routernum => $args{'routernum'}}); + } else { + $router = $svc_broadband->addr_block->router; + } + + return($router); + } -sub ssh_cmd { #subroutine, not method + +# Subroutines +sub ssh_cmd { use Net::SSH '0.08'; &Net::SSH::ssh_cmd( { @_ } ); } @@ -179,12 +273,4 @@ sub telnet_cmd { die @error if (grep /^ERROR/, @error); } -#sub router_insert { #subroutine, not method -#} -#sub router_replace { #subroutine, not method -#} -#sub router_delete { #subroutine, not method -#} - 1; - diff --git a/FS/FS/part_export/shellcommands.pm b/FS/FS/part_export/shellcommands.pm index 646c5ff71..b43033405 100644 --- a/FS/FS/part_export/shellcommands.pm +++ b/FS/FS/part_export/shellcommands.pm @@ -4,6 +4,7 @@ use vars qw(@ISA %info); use Tie::IxHash; use String::ShellQuote; use FS::part_export; +use FS::Record qw( qsearch qsearchs ); @ISA = qw(FS::part_export); @@ -60,6 +61,10 @@ tie my %options, 'Tie::IxHash', type=>'select', options=>[qw(crypt md5)], default => 'crypt', }, + 'groups_susp_reason' => { label => + 'Radius group mapping to reason (via template user)', + type => 'textarea', + }, ; %info = ( @@ -151,22 +156,33 @@ old_ for replace operations): <UL> <LI><code>$username</code> <LI><code>$_password</code> - <LI><code>$quoted_password</code> - unencrypted password, already quoted for the shell (do not add additional quotes) - <LI><code>$crypt_password</code> - encrypted password, already quoted for the shell (do not add additional quotes) + <LI><code>$quoted_password</code> - unencrypted password, already quoted for the shell (do not add additional quotes). + <LI><code>$crypt_password</code> - encrypted password. When used on the command line (rather than STDIN), it will be already quoted for the shell (do not add additional quotes). <LI><code>$uid</code> <LI><code>$gid</code> - <LI><code>$finger</code> - GECOS, already quoted for the shell (do not add additional quotes) - <LI><code>$first</code> - First name of GECOS, already quoted for the shell (do not add additional quotes) - <LI><code>$last</code> - Last name of GECOS, already quoted for the shell (do not add additional quotes) + <LI><code>$finger</code> - GECOS. When used on the command line (rather than STDIN), it will be already quoted for the shell (do not add additional quotes). + <LI><code>$first</code> - First name of GECOS. When used on the command line (rather than STDIN), it will be already quoted for the shell (do not add additional quotes). + <LI><code>$last</code> - Last name of GECOS. When used on the command line (rather than STDIN), it will be already quoted for the shell (do not add additional quotes). <LI><code>$dir</code> - home directory <LI><code>$shell</code> <LI><code>$quota</code> <LI><code>@radius_groups</code> + <LI><code>$reasonnum (when suspending)</code> + <LI><code>$reasontext (when suspending)</code> + <LI><code>$reasontypenum (when suspending)</code> + <LI><code>$reasontypetext (when suspending)</code> <LI>All other fields in <a href="../docs/schema.html#svc_acct">svc_acct</a> are also available. </UL> END ); +sub _groups_susp_reason_map { shift->_map('groups_susp_reason'); } + +sub _map { + my $self = shift; + map { reverse(/^\s*(\S+)\s*(.*)\s*$/) } split("\n", $self->option(shift) ); +} + sub rebless { shift; } sub _export_insert { @@ -199,7 +215,6 @@ sub _export_command_or_super { } }; - sub _export_command { my ( $self, $action, $svc_acct) = (shift, shift, shift); my $command = $self->option($action); @@ -211,6 +226,7 @@ sub _export_command { no strict 'refs'; ${$_} = $svc_acct->getfield($_) foreach $svc_acct->fields; + # snarfs are unused at this point? my $count = 1; foreach my $acct_snarf ( $svc_acct->acct_snarf ) { ${"snarf_$_$count"} = shell_quote( $acct_snarf->get($_) ) @@ -228,22 +244,61 @@ sub _export_command { $finger =~ /^(.*)\s+(\S+)$/ or $finger =~ /^((.*))$/; ($first, $last ) = ( $1, $2 ); - $first = shell_quote $first; - $last = shell_quote $last; - $finger = shell_quote $finger; - $quoted_password = shell_quote $_password; $domain = $svc_acct->domain; - $crypt_password = - shell_quote( $svc_acct->crypt_password( $self->option('crypt') ) ); + $quoted_password = shell_quote $_password; + + $crypt_password = $svc_acct->crypt_password( $self->option('crypt') ); @radius_groups = $svc_acct->radius_groups; + my ($reasonnum, $reasontext, $reasontypenum, $reasontypetext); + if ( $cust_pkg && $action eq 'suspend' && (my $r = $cust_pkg->last_reason) ) { + $reasonnum = $r->reasonnum; + $reasontext = $r->reason; + $reasontypenum = $r->reason_type; + $reasontypetext = $r->reasontype->type; + + my %reasonmap = $self->_groups_susp_reason_map; + my $userspec = ''; + $userspec = $reasonmap{$reasonnum} + if exists($reasonmap{$reasonnum}); + $userspec = $reasonmap{$reasontext} + if (!$userspec && exists($reasonmap{$reasontext})); + + my $suspend_user; + if ( $userspec =~ /^\d+$/ ) { + $suspend_user = qsearchs( 'svc_acct', { 'svcnum' => $userspec } ); + } elsif ( $userspec =~ /^\S+\@\S+$/ ) { + my ($username,$domain) = split(/\@/, $userspec); + for my $user (qsearch( 'svc_acct', { 'username' => $username } )){ + $suspend_user = $user if $userspec eq $user->email; + } + } elsif ($userspec) { + $suspend_user = qsearchs( 'svc_acct', { 'username' => $userspec } ); + } + + @radius_groups = $suspend_user->radius_groups + if $suspend_user; + + } else { + $reasonnum = $reasontext = $reasontypenum = $reasontypetext = ''; + } + + my $stdin_string = eval(qq("$stdin")); + + $first = shell_quote $first; + $last = shell_quote $last; + $finger = shell_quote $finger; + $crypt_password = shell_quote $crypt_password; + + my $command_string = eval(qq("$command")); + $self->shellcommands_queue( $svc_acct->svcnum, user => $self->option('user')||'root', host => $self->machine, - command => eval(qq("$command")), - stdin_string => eval(qq("$stdin")), + command => $command_string, + stdin_string => $stdin_string, ); } @@ -257,18 +312,14 @@ sub _export_replace { ${"old_$_"} = $old->getfield($_) foreach $old->fields; ${"new_$_"} = $new->getfield($_) foreach $new->fields; } - $new_finger =~ /^(.*)\s+(\S+)$/ or $finger =~ /^((.*))$/; + $new_finger =~ /^(.*)\s+(\S+)$/ or $new_finger =~ /^((.*))$/; ($new_first, $new_last ) = ( $1, $2 ); - $new_first = shell_quote $new_first; - $new_last = shell_quote $new_last; - $new_finger = shell_quote $new_finger; $quoted_new__password = shell_quote $new__password; #old, wrong? $new_quoted_password = shell_quote $new__password; #new, better? $old_domain = $old->domain; $new_domain = $new->domain; - $new_crypt_password = - shell_quote( $new->crypt_password( $self->option('crypt') ) ); + $new_crypt_password = $new->crypt_password( $self->option('crypt') ); @old_radius_groups = $old->radius_groups; @new_radius_groups = $new->radius_groups; @@ -300,11 +351,20 @@ sub _export_replace { return $error. ' ('. $self->exporttype. ' to '. $self->machine. ')' if $error; + my $stdin_string = eval(qq("$stdin")); + + $new_first = shell_quote $new_first; + $new_last = shell_quote $new_last; + $new_finger = shell_quote $new_finger; + $new_crypt_password = shell_quote $new_crypt_password; + + my $command_string = eval(qq("$command")); + $self->shellcommands_queue( $new->svcnum, user => $self->option('user')||'root', host => $self->machine, - command => eval(qq("$command")), - stdin_string => eval(qq("$stdin")), + command => $command_string, + stdin_string => $stdin_string, ); } diff --git a/FS/FS/part_export/snmp.pm b/FS/FS/part_export/snmp.pm new file mode 100644 index 000000000..81b3c7eb2 --- /dev/null +++ b/FS/FS/part_export/snmp.pm @@ -0,0 +1,256 @@ +package FS::part_export::snmp; + +=head1 FS::part_export::snmp + +This export sends SNMP SETs to a router using the Net::SNMP package. It requires the following custom fields to be defined on a router. If any of the required custom fields are not present, then the export will exit quietly. + +=head1 Required custom fields + +=over 4 + +=item snmp_address - IP address (or hostname) of the router/agent + +=item snmp_comm - R/W SNMP community of the router/agent + +=item snmp_version - SNMP version of the router/agent + +=back + +=head1 Optional custom fields + +=over 4 + +=item snmp_cmd_insert - SNMP SETs to perform on insert. See L</Formatting> + +=item snmp_cmd_replace - SNMP SETs to perform on replace. See L</Formatting> + +=item snmp_cmd_delete - SNMP SETs to perform on delete. See L</Formatting> + +=item snmp_cmd_suspend - SNMP SETs to perform on suspend. See L</Formatting> + +=item snmp_cmd_unsuspend - SNMP SETs to perform on unsuspend. See L</Formatting> + +=back + +=head1 Formatting + +The values for the snmp_cmd_* fields should be formatted as follows: + +<OID>|<Data Type>|<expr>[||<OID>|<Data Type>|<expr>[...]] + +=over 4 + +=item OID - SNMP object ID (ex. 1.3.6.1.4.1.1.20). If the OID string starts with a '.', then the Private Enterprise OID (1.3.6.1.4.1) is prepended. + +=item Data Type - SNMP data types understood by L<Net::SNMP>, as well as HEX_STRING for convenience. ex. INTEGER, OCTET_STRING, IPADDRESS, ... + +=item expr - Expression to be eval'd by freeside. By default, the expression is double quoted and eval'd with all FS::svc_broadband fields available as scalars (ex. $svcnum, $ip_addr, $speed_up). However, if the expression contains a non-escaped double quote, the expression is eval'd without being double quoted. In this case, the expression must be a block of valid perl code that returns the desired value. + +You must escape non-delimiter pipes ("|") with a backslash. + +=back + +=head1 Examples + +This is an example for exporting to a Trango Access5830 AP. Newlines inserted for clarity. + +=over 4 + +=item snmp_cmd_delete - + +1.3.6.1.4.1.5454.1.20.3.5.1|INTEGER|50|| +1.3.6.1.4.1.5454.1.20.3.5.8|INTEGER|1| + +=item snmp_cmd_insert - + +1.3.6.1.4.1.5454.1.20.3.5.1|INTEGER|50|| +1.3.6.1.4.1.5454.1.20.3.5.2|HEX_STRING|join("",$radio_addr =~ /[0-9a-fA-F]{2}/g)|| +1.3.6.1.4.1.5454.1.20.3.5.7|INTEGER|1| + +=item snmp_cmd_replace - + +1.3.6.1.4.1.5454.1.20.3.5.1|INTEGER|50|| +1.3.6.1.4.1.5454.1.20.3.5.8|INTEGER|1||1.3.6.1.4.1.5454.1.20.3.5.1|INTEGER|50|| +1.3.6.1.4.1.5454.1.20.3.5.2|HEX_STRING|join("",$new_radio_addr =~ /[0-9a-fA-F]{2}/g)|| +1.3.6.1.4.1.5454.1.20.3.5.7|INTEGER|1| + +=back + +=cut + + +use strict; +use vars qw(@ISA %info $me $DEBUG); +use Tie::IxHash; +use FS::Record qw(qsearch qsearchs); +use FS::part_export; +use FS::part_export::router; + +@ISA = qw(FS::part_export::router); + +tie my %options, 'Tie::IxHash', (); + +%info = ( + 'svc' => 'svc_broadband', + 'desc' => 'Sends SNMP SETs to an SNMP agent.', + 'options' => \%options, + 'notes' => 'Requires Net::SNMP. See the documentation for FS::part_export::snmp for required virtual fields and usage information.', +); + +$me= '[' . __PACKAGE__ . ']'; +$DEBUG = 1; + + +sub _field_prefix { 'snmp'; } + +sub _req_router_fields { + map { + $_[0]->_field_prefix . '_' . $_ + } (qw(address comm version)); +} + +sub _get_cmd_sub { + + my ($self, $svc_broadband, $router) = (shift, shift, shift); + + return(ref($self) . '::snmp_cmd'); + +} + +sub _prepare_args { + + my ($self, $action, $router) = (shift, shift, shift); + my ($svc_broadband) = shift; + my $old; + my $field_prefix = $self->_field_prefix; + + if ($action eq 'replace') { $old = shift; } + + my $raw_cmd = $router->getfield("${field_prefix}_cmd_${action}"); + unless ($raw_cmd) { + warn "[debug]$me router custom field '${field_prefix}_cmd_$action' " + . "is not defined." if $DEBUG; + return ''; + } + + my $args = [ + '-hostname' => $router->getfield($field_prefix.'_address'), + '-version' => $router->getfield($field_prefix.'_version'), + '-community' => $router->getfield($field_prefix.'_comm'), + ]; + + my @varbindlist = (); + + foreach my $snmp_cmd ($raw_cmd =~ m/(.*?[^\\])(?:\|\||$)/g) { + + warn "[debug]$me snmp_cmd is '$snmp_cmd'" if $DEBUG; + + my ($oid, $type, $expr) = $snmp_cmd =~ m/(.*?[^\\])(?:\||$)/g; + + if ($oid =~ /^([\d\.]+)$/) { + $oid = $1; + $oid = ($oid =~ /^\./) ? '1.3.6.1.4.1' . $oid : $oid; + } else { + return "Invalid SNMP OID '$oid'"; + } + + if ($type =~ /^([A-Z_\d]+)$/) { + $type = $1; + } else { + return "Invalid SNMP ASN.1 type '$type'"; + } + + if ($expr =~ /^(.*)$/) { + $expr = $1; + } else { + return "Invalid expression '$expr'"; + } + + { + no strict 'vars'; + no strict 'refs'; + + if ($action eq 'replace') { + ${"old_$_"} = $old->getfield($_) foreach $old->fields; + ${"new_$_"} = $svc_broadband->getfield($_) foreach $svc_broadband->fields; + $expr = ($expr =~/[^\\]"/) ? eval($expr) : eval(qq("$expr")); + } else { + ${$_} = $svc_broadband->getfield($_) foreach $svc_broadband->fields; + $expr = ($expr =~/[^\\]"/) ? eval($expr) : eval(qq("$expr")); + } + return $@ if $@; + } + + push @varbindlist, ($oid, $type, $expr); + + } + + push @$args, ('-varbindlist', @varbindlist); + + return('', $args); + +} + +sub snmp_cmd { + eval "use Net::SNMP;"; + die $@ if $@; + + my %args = (); + my @varbindlist = (); + while (scalar(@_)) { + my $key = shift; + if ($key eq '-varbindlist') { + push @varbindlist, @_; + last; + } else { + $args{$key} = shift; + } + } + + my $i = 0; + while ($i*3 < scalar(@varbindlist)) { + my $type_index = ($i*3)+1; + my $type_name = $varbindlist[$type_index]; + + # Implementing HEX_STRING outselves since Net::SNMP doesn't. Ewwww! + if ($type_name eq 'HEX_STRING') { + my $value_index = $type_index + 1; + $type_name = 'OCTET_STRING'; + $varbindlist[$value_index] = pack('H*', $varbindlist[$value_index]); + } + + my $type = eval "Net::SNMP::$type_name"; + if ($@ or not defined $type) { + warn $@ if $DEBUG; + die "snmp_cmd error: Unable to lookup type '$type_name'"; + } + + $varbindlist[$type_index] = $type; + } continue { + $i++; + } + + my ($snmp, $error) = Net::SNMP->session(%args); + die "snmp_cmd error: $error" unless($snmp); + + my $res = $snmp->set_request('-varbindlist' => \@varbindlist); + unless($res) { + $error = $snmp->error; + $snmp->close; + die "snmp_cmd error: " . $error; + } + + $snmp->close; + + return ''; + +} + + +=head1 BUGS + +Plenty, I'm sure. + +=cut + +1; diff --git a/FS/FS/part_export/sqlmail.pm b/FS/FS/part_export/sqlmail.pm index 6d61e0e29..cbdaf7f52 100644 --- a/FS/FS/part_export/sqlmail.pm +++ b/FS/FS/part_export/sqlmail.pm @@ -25,9 +25,9 @@ tie my %options, 'Tie::IxHash', 'svc_acct_fields' => { label => 'svc_acct Export Fields', default => 'username _password domsvc svcnum' }, 'svc_forward_fields' => { label => 'svc_forward Export Fields', - default => 'domain svcnum catchall' }, - 'svc_domain_fields' => { label => 'svc_domain Export Fields', default => 'srcsvc dstsvc dst' }, + 'svc_domain_fields' => { label => 'svc_domain Export Fields', + default => 'domain svcnum catchall' }, 'resolve_dstsvc' => { label => q{Resolve svc_forward.dstsvc to an email address and store it in dst. (Doesn't require that you also export dstsvc.)}, type => 'checkbox' }, ; diff --git a/FS/FS/part_export/sqlradius.pm b/FS/FS/part_export/sqlradius.pm index 10bccb034..139f4001f 100644 --- a/FS/FS/part_export/sqlradius.pm +++ b/FS/FS/part_export/sqlradius.pm @@ -2,7 +2,7 @@ package FS::part_export::sqlradius; use vars qw(@ISA $DEBUG %info %options $notes1 $notes2); use Tie::IxHash; -use FS::Record qw( dbh qsearch ); +use FS::Record qw( dbh qsearch qsearchs ); use FS::part_export; use FS::svc_acct; use FS::export_svc; @@ -31,6 +31,12 @@ tie %options, 'Tie::IxHash', type => 'checkbox', label => 'Show the Called-Station-ID on session reports', }, + 'overlimit_groups' => { label => 'Radius groups to assign to svc_acct which has exceeded its bandwidth or time limit', } , + 'groups_susp_reason' => { label => + 'Radius group mapping to reason (via template user) (svcnum|username|username@domain reasonnum|reason)', + type => 'textarea', + }, + ; $notes1 = <<'END'; @@ -75,6 +81,10 @@ END $notes2 ); +sub _groups_susp_reason_map { map { reverse( /^\s*(\S+)\s*(.*)$/ ) } + split( "\n", shift->option('groups_susp_reason')); +} + sub rebless { shift; } sub export_username { @@ -170,50 +180,99 @@ sub _export_replace { } } - # (sorta) false laziness with FS::svc_acct::replace - my @oldgroups = @{$old->usergroup}; #uuuh - my @newgroups = $new->radius_groups; - my @delgroups = (); - foreach my $oldgroup ( @oldgroups ) { - if ( grep { $oldgroup eq $_ } @newgroups ) { - @newgroups = grep { $oldgroup ne $_ } @newgroups; - next; - } - push @delgroups, $oldgroup; + my $error; + my (@oldgroups) = $old->radius_groups; + my (@newgroups) = $new->radius_groups; + $error = $self->sqlreplace_usergroups( $new->svcnum, + $self->export_username($new), + $jobnum ? $jobnum : '', + \@oldgroups, + \@newgroups, + ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; } - if ( @delgroups ) { - my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'usergroup_delete', - $self->export_username($new), @delgroups ); - unless ( ref($err_or_queue) ) { - $dbh->rollback if $oldAutoCommit; - return $err_or_queue; - } - if ( $jobnum ) { - my $error = $err_or_queue->depend_insert( $jobnum ); - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return $error; - } - } + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; +} + +sub _export_suspend { + my( $self, $svc_acct ) = (shift, shift); + + my $new = $svc_acct->clone_suspended; + + 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 $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'insert', + 'check', $self->export_username($new), $new->radius_check ); + unless ( ref($err_or_queue) ) { + $dbh->rollback if $oldAutoCommit; + return $err_or_queue; } - if ( @newgroups ) { - my $err_or_queue = $self->sqlradius_queue( $new->svcnum, 'usergroup_insert', - $self->export_username($new), @newgroups ); - unless ( ref($err_or_queue) ) { - $dbh->rollback if $oldAutoCommit; - return $err_or_queue; - } - if ( $jobnum ) { - my $error = $err_or_queue->depend_insert( $jobnum ); - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return $error; - } - } + my $error; + my (@newgroups) = $self->suspended_usergroups($svc_acct); + $error = + $self->sqlreplace_usergroups( $new->svcnum, + $self->export_username($new), + '', + $svc_acct->usergroup, + \@newgroups, + ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; +} + +sub _export_unsuspend { + my( $self, $svc_acct ) = (shift, 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 $err_or_queue = $self->sqlradius_queue( $svc_acct->svcnum, 'insert', + 'check', $self->export_username($svc_acct), $svc_acct->radius_check ); + unless ( ref($err_or_queue) ) { + $dbh->rollback if $oldAutoCommit; + return $err_or_queue; } + my $error; + my (@oldgroups) = $self->suspended_usergroups($svc_acct); + $error = $self->sqlreplace_usergroups( $svc_acct->svcnum, + $self->export_username($svc_acct), + '', + \@oldgroups, + $svc_acct->usergroup, + ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } $dbh->commit or die $dbh->errstr if $oldAutoCommit; ''; @@ -240,6 +299,39 @@ sub sqlradius_queue { ) or $queue; } +sub suspended_usergroups { + my ($self, $svc_acct) = (shift, shift); + + return () unless $svc_acct; + + #false laziness with FS::part_export::shellcommands + #subclass part_export? + + my $r = $svc_acct->cust_svc->cust_pkg->last_reason; + my %reasonmap = $self->_groups_susp_reason_map; + my $userspec = ''; + if ($r) { + $userspec = $reasonmap{$r->reasonnum} + if exists($reasonmap{$r->reasonnum}); + $userspec = $reasonmap{$r->reason} + if (!$userspec && exists($reasonmap{$r->reason})); + } + my $suspend_user; + if ($userspec =~ /^d+$/ ){ + $suspend_user = qsearchs( 'svc_acct', { 'svcnum' => $userspec } ); + }elsif ($userspec =~ /^\S+\@\S+$/){ + my ($username,$domain) = split(/\@/, $userspec); + for my $user (qsearch( 'svc_acct', { 'username' => $username } )){ + $suspend_user = $user if $userspec eq $user->email; + } + }elsif ($userspec){ + $suspend_user = qsearchs( 'svc_acct', { 'username' => $userspec } ); + } + #esalf + return $suspend_user->radius_groups if $suspend_user; + (); +} + sub sqlradius_insert { #subroutine, not method my $dbh = sqlradius_connect(shift, shift, shift); my( $table, $username, %attributes ) = @_; @@ -350,6 +442,46 @@ sub sqlradius_connect { DBI->connect(@_) or die $DBI::errstr; } +sub sqlreplace_usergroups { + my ($self, $svcnum, $username, $jobnum, $old, $new) = @_; + + # (sorta) false laziness with FS::svc_acct::replace + my @oldgroups = @$old; + my @newgroups = @$new; + my @delgroups = (); + foreach my $oldgroup ( @oldgroups ) { + if ( grep { $oldgroup eq $_ } @newgroups ) { + @newgroups = grep { $oldgroup ne $_ } @newgroups; + next; + } + push @delgroups, $oldgroup; + } + + if ( @delgroups ) { + my $err_or_queue = $self->sqlradius_queue( $svcnum, 'usergroup_delete', + $username, @delgroups ); + return $err_or_queue + unless ref($err_or_queue); + if ( $jobnum ) { + my $error = $err_or_queue->depend_insert( $jobnum ); + return $error if $error; + } + } + + if ( @newgroups ) { + my $err_or_queue = $self->sqlradius_queue( $svcnum, 'usergroup_insert', + $username, @newgroups ); + return $err_or_queue + unless ref($err_or_queue); + if ( $jobnum ) { + my $error = $err_or_queue->depend_insert( $jobnum ); + return $error if $error; + } + } + ''; +} + + #-- =item usage_sessions TIMESTAMP_START TIMESTAMP_END [ SVC_ACCT [ IP [ PREFIX [ SQL_SELECT ] ] ] ] @@ -484,7 +616,8 @@ sub update_svc_acct { my $where = ''; my $sth = $dbh->prepare(" - SELECT RadAcctId, UserName, Realm, AcctSessionTime + SELECT RadAcctId, UserName, Realm, AcctSessionTime, + AcctInputOctets, AcctOutputOctets FROM radacct WHERE FreesideStatus IS NULL AND AcctStopTime != 0 @@ -492,7 +625,8 @@ sub update_svc_acct { $sth->execute() or die $sth->errstr; while ( my $row = $sth->fetchrow_arrayref ) { - my($RadAcctId, $UserName, $Realm, $AcctSessionTime) = @$row; + my($RadAcctId, $UserName, $Realm, $AcctSessionTime, + $AcctInputOctets, $AcctOutputOctets) = @$row; warn "processing record: ". "$RadAcctId ($UserName\@$Realm for ${AcctSessionTime}s" if $DEBUG; @@ -502,7 +636,6 @@ sub update_svc_acct { if ( ref($self) =~ /withdomain/ ) { #well... $extra_sql = " AND '$Realm' = ( SELECT domain FROM svc_domain WHERE svc_domain.svcnum = svc_acct.domsvc ) "; - my $svc_domain = qsearch } my @svc_acct = @@ -523,18 +656,16 @@ sub update_svc_acct { } elsif ( scalar(@svc_acct) > 1 ) { warn "WARNING: multiple svc_acct records found $errinfo - skipping\n"; } else { - my $svc_acct = $svc_acct[0]; - warn "found svc_acct ". $svc_acct->svcnum. " $errinfo\n" if $DEBUG; - if ( $svc_acct->seconds !~ /^$/ ) { - warn " svc_acct.seconds found (". $svc_acct->seconds. - ") - decrementing\n" - if $DEBUG; - my $error = $svc_acct->decrement_seconds($AcctSessionTime); - die $error if $error; - $status = 'done'; - } else { - warn " no existing seconds value for svc_acct - skiping\n" if $DEBUG; - } + warn "found svc_acct ". $svc_acct[0]->svcnum. " $errinfo\n" if $DEBUG; + _try_decrement($svc_acct[0], 'seconds', $AcctSessionTime) + and $status='done'; + _try_decrement($svc_acct[0], 'upbytes', $AcctInputOctets) + and $status='done'; + _try_decrement($svc_acct[0], 'downbytes', $AcctOutputOctets) + and $status='done'; + _try_decrement($svc_acct[0], 'totalbytes', $AcctInputOctets + + $AcctOutputOctets) + and $status='done'; } warn "setting FreesideStatus to $status $errinfo\n" if $DEBUG; @@ -548,5 +679,21 @@ sub update_svc_acct { } +sub _try_decrement { + my ($svc_acct, $column, $amount) = @_; + if ( $svc_acct->$column !~ /^$/ ) { + warn " svc_acct.$column found (". $svc_acct->$column. + ") - decrementing\n" + if $DEBUG; + my $method = 'decrement_' . $column; + my $error = $svc_acct->$method($amount); + die $error if $error; + return 'done'; + } else { + warn " no existing $column value for svc_acct - skipping\n" if $DEBUG; + } + return ''; +} + 1; diff --git a/FS/FS/part_export/trango.pm b/FS/FS/part_export/trango.pm new file mode 100644 index 000000000..e7f1126dd --- /dev/null +++ b/FS/FS/part_export/trango.pm @@ -0,0 +1,434 @@ +package FS::part_export::trango; + +=head1 FS::part_export::trango + +This export sends SNMP SETs to a router using the Net::SNMP package. It requires the following custom fields to be defined on a router. If any of the required custom fields are not present, then the export will exit quietly. + +=head1 Required custom fields + +=over 4 + +=item trango_address - IP address (or hostname) of the Trango AP. + +=item trango_comm - R/W SNMP community of the Trango AP. + +=item trango_ap_type - Trango AP Model. Currently 'access5830' is the only supported option. + +=back + +=head1 Optional custom fields + +=over 4 + +=item trango_baseid - Base ID of the Trango AP. See L</"Generating SU IDs">. + +=item trango_apid - AP ID of the Trango AP. See L</"Generating SU IDs">. + +=back + +=head1 Generating SU IDs + +This export will/must generate a unique SU ID for each service exported to a Trango AP. It can be done such that SU IDs are globally unique, unique per Base ID, or unique per Base ID/AP ID pair. This is accomplished by setting neither trango_baseid and trango_apid, only trango_baseid, or both trango_baseid and trango_apid, respectively. An SU ID will be generated if the FS::svc_broadband virtual field specified by suid_field export option is unset, otherwise the existing value will be used. + +=head1 Device Support + +This export has been tested with the Trango Access5830 AP. + + +=cut + + +use strict; +use vars qw(@ISA %info $me $DEBUG $trango_mib $counter_dir); + +use FS::UID qw(dbh datasrc); +use FS::Record qw(qsearch qsearchs); +use FS::part_export::snmp; + +use Tie::IxHash; +use File::CounterFile; +use Data::Dumper qw(Dumper); + +@ISA = qw(FS::part_export::snmp); + +tie my %options, 'Tie::IxHash', ( + 'suid_field' => { + 'label' => 'Trango SU ID field', + 'default' => 'trango_suid', + 'notes' => 'Name of the FS::svc_broadband virtual field that will contain the SU ID.', + }, + 'mac_field' => { + 'label' => 'Trango MAC address field', + 'default' => '', + 'notes' => 'Name of the FS::svc_broadband virtual field that will contain the SU\'s MAC address.', + }, +); + +%info = ( + 'svc' => 'svc_broadband', + 'desc' => 'Sends SNMP SETs to a Trango AP.', + 'options' => \%options, + 'notes' => 'Requires Net::SNMP. See the documentation for FS::part_export::trango for required virtual fields and usage information.', +); + +$me= '[' . __PACKAGE__ . ']'; +$DEBUG = 1; + +$trango_mib = { + 'access5830' => { + 'snmpversion' => 'snmpv1', + 'varbinds' => { + 'insert' => [ + { # sudbDeleteOrAddID + 'oid' => '1.3.6.1.4.1.5454.1.20.3.5.1', + 'type' => 'INTEGER', + 'value' => \&_trango_access5830_sudbDeleteOrAddId, + }, + { # sudbAddMac + 'oid' => '1.3.6.1.4.1.5454.1.20.3.5.2', + 'type' => 'HEX_STRING', + 'value' => \&_trango_access5830_sudbAddMac, + }, + { # sudbAddSU + 'oid' => '1.3.6.1.4.1.5454.1.20.3.5.7', + 'type' => 'INTEGER', + 'value' => 1, + }, + ], + 'delete' => [ + { # sudbDeleteOrAddID + 'oid' => '1.3.6.1.4.1.5454.1.20.3.5.1', + 'type' => 'INTEGER', + 'value' => \&_trango_access5830_sudbDeleteOrAddId, + }, + { # sudbDeleteSU + 'oid' => '1.3.6.1.4.1.5454.1.20.3.5.8', + 'type' => 'INTEGER', + 'value' => 1, + }, + ], + 'replace' => [ + { # sudbDeleteOrAddID + 'oid' => '1.3.6.1.4.1.5454.1.20.3.5.1', + 'type' => 'INTEGER', + 'value' => \&_trango_access5830_sudbDeleteOrAddId, + }, + { # sudbDeleteSU + 'oid' => '1.3.6.1.4.1.5454.1.20.3.5.8', + 'type' => 'INTEGER', + 'value' => 1, + }, + { # sudbDeleteOrAddID + 'oid' => '1.3.6.1.4.1.5454.1.20.3.5.1', + 'type' => 'INTEGER', + 'value' => \&_trango_access5830_sudbDeleteOrAddId, + }, + { # sudbAddMac + 'oid' => '1.3.6.1.4.1.5454.1.20.3.5.2', + 'type' => 'HEX_STRING', + 'value' => \&_trango_access5830_sudbAddMac, + }, + { # sudbAddSU + 'oid' => '1.3.6.1.4.1.5454.1.20.3.5.7', + 'type' => 'INTEGER', + 'value' => 1, + }, + ], + 'suspend' => [ + { # sudbDeleteOrAddID + 'oid' => '1.3.6.1.4.1.5454.1.20.3.5.1', + 'type' => 'INTEGER', + 'value' => \&_trango_access5830_sudbDeleteOrAddId, + }, + { # sudbDeleteSU + 'oid' => '1.3.6.1.4.1.5454.1.20.3.5.8', + 'type' => 'INTEGER', + 'value' => 1, + }, + ], + 'unsuspend' => [ + { # sudbDeleteOrAddID + 'oid' => '1.3.6.1.4.1.5454.1.20.3.5.1', + 'type' => 'INTEGER', + 'value' => \&_trango_access5830_sudbDeleteOrAddId, + }, + { # sudbAddMac + 'oid' => '1.3.6.1.4.1.5454.1.20.3.5.2', + 'type' => 'HEX_STRING', + 'value' => \&_trango_access5830_sudbAddMac, + }, + { # sudbAddSU + 'oid' => '1.3.6.1.4.1.5454.1.20.3.5.7', + 'type' => 'INTEGER', + 'value' => 1, + }, + ], + }, + }, +}; + + +sub _field_prefix { 'trango'; } + +sub _req_router_fields { + map { + $_[0]->_field_prefix . '_' . $_ + } (qw(address comm ap_type suid_field)); +} + +sub _get_cmd_sub { + + return('FS::part_export::snmp::snmp_cmd'); + +} + +sub _prepare_args { + + my ($self, $action, $router) = (shift, shift, shift); + my ($svc_broadband) = shift; + my $old = shift if $action eq 'replace'; + my $field_prefix = $self->_field_prefix; + my $error; + + my $ap_type = $router->getfield($field_prefix . '_ap_type'); + + unless (exists $trango_mib->{$ap_type}) { + return "Unsupported Trango AP type '$ap_type'"; + } + + $error = $self->_check_suid( + $action, $router, $svc_broadband, ($old) ? $old : () + ); + return $error if $error; + + $error = $self->_check_mac( + $action, $router, $svc_broadband, ($old) ? $old : () + ); + return $error if $error; + + my $ap_mib = $trango_mib->{$ap_type}; + + my $args = [ + '-hostname' => $router->getfield($field_prefix.'_address'), + '-version' => $ap_mib->{'snmpversion'}, + '-community' => $router->getfield($field_prefix.'_comm'), + ]; + + my @varbindlist = (); + + foreach my $oid (@{$ap_mib->{'varbinds'}->{$action}}) { + warn "[debug]$me Processing OID '" . $oid->{'oid'} . "'" if $DEBUG; + my $value; + if (ref($oid->{'value'}) eq 'CODE') { + eval { + $value = &{$oid->{'value'}}( + $self, $action, $router, $svc_broadband, + (($old) ? $old : ()), + ); + }; + return "While processing OID '" . $oid->{'oid'} . "':" . $@ + if $@; + } else { + $value = $oid->{'value'}; + } + + warn "[debug]$me Value for OID '" . $oid->{'oid'} . "': " if $DEBUG; + + if (defined $value) { # Skip OIDs with undefined values. + push @varbindlist, ($oid->{'oid'}, $oid->{'type'}, $value); + } + } + + + push @$args, ('-varbindlist', @varbindlist); + + return('', $args); + +} + +sub _check_suid { + + my ($self, $action, $router, $svc_broadband) = (shift, shift, shift, shift); + my $old = shift if $action eq 'replace'; + my $error; + + my $suid_field = $self->option('suid_field'); + unless (grep {$_ eq $suid_field} $svc_broadband->fields) { + return "Missing Trango SU ID field. " + . "See the trango export options for more info."; + } + + my $suid = $svc_broadband->getfield($suid_field); + if ($action eq 'replace') { + my $old_suid = $old->getfield($suid_field); + + if ($old_suid ne '' and $old_suid ne $suid) { + return 'Cannot change Trango SU ID'; + } + } + + if (not $suid =~ /^\d+$/ and $action ne 'delete') { + my $new_suid = eval { $self->_get_next_suid($router); }; + return "Error while getting next Trango SU ID: $@" if ($@); + + warn "[debug]$me Got new SU ID: $new_suid" if $DEBUG; + $svc_broadband->set($suid_field, $new_suid); + + #FIXME: Probably a bad hack. + # We need to update the SU ID field in the database. + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::svc_Common::noexport_hack = 1; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + my $svcnum = $svc_broadband->svcnum; + + my $old_svc = qsearchs('svc_broadband', { svcnum => $svcnum }); + unless ($old_svc) { + return "Unable to retrieve svc_broadband with svcnum '$svcnum"; + } + + my $svcpart = $svc_broadband->svcpart + ? $svc_broadband->svcpart + : $svc_broadband->cust_svc->svcpart; + + my $new_svc = new FS::svc_broadband { + $old_svc->hash, + $suid_field => $new_suid, + svcpart => $svcpart, + }; + + $error = $new_svc->check; + if ($error) { + $dbh->rollback if $oldAutoCommit; + return "Error while updating the Trango SU ID: $error" if $error; + } + + warn "[debug]$me Updating svc_broadband with SU ID '$new_suid'...\n" . + &Dumper($new_svc) if $DEBUG; + + $error = eval { $new_svc->replace($old_svc); }; + + if ($@ or $error) { + $error ||= $@; + $dbh->rollback if $oldAutoCommit; + return "Error while updating the Trango SU ID: $error" if $error; + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + } + + return ''; + +} + +sub _check_mac { + + my ($self, $action, $router, $svc_broadband) = (shift, shift, shift, shift); + my $old = shift if $action eq 'replace'; + + my $mac_field = $self->option('mac_field'); + unless (grep {$_ eq $mac_field} $svc_broadband->fields) { + return "Missing Trango MAC address field. " + . "See the trango export options for more info."; + } + + my $mac_addr = $svc_broadband->getfield($mac_field); + unless (length(join('', $mac_addr =~ /[0-9a-fA-F]/g)) == 12) { + return "Invalid Trango MAC address: $mac_addr"; + } + + return(''); + +} + +sub _get_next_suid { + + my ($self, $router) = (shift, shift); + + my $counter_dir = '/usr/local/etc/freeside/export.'. datasrc . '/trango'; + my $baseid = $router->getfield('trango_baseid'); + my $apid = $router->getfield('trango_apid'); + + my $counter_file_suffix = ''; + if ($baseid ne '') { + $counter_file_suffix .= "_B$baseid"; + if ($apid ne '') { + $counter_file_suffix .= "_A$apid"; + } + } + + my $counter_file = $counter_dir . '/SUID' . $counter_file_suffix; + + warn "[debug]$me Using SUID counter file '$counter_file'"; + + my $suid = eval { + mkdir $counter_dir, 0700 unless -d $counter_dir; + + my $cf = new File::CounterFile($counter_file, 0); + $cf->inc; + }; + + die "Error generating next Trango SU ID: $@" if (not $suid or $@); + + return($suid); + +} + + + +# Trango-specific subroutines for generating varbind values. +# +# All subs should die on error, and return undef to decline. OIDs that +# decline will not be added to varbinds. + +sub _trango_access5830_sudbDeleteOrAddId { + + my ($self, $action, $router) = (shift, shift, shift); + my ($svc_broadband) = shift; + my $old = shift if $action eq 'replace'; + + my $suid = $svc_broadband->getfield($self->option('suid_field')); + + # Sanity check. + unless ($suid =~ /^\d+$/) { + if ($action eq 'delete') { + # Silently ignore. If we don't have a valid SU ID now, we probably + # never did. + return undef; + } else { + die "Invalid Trango SU ID '$suid'"; + } + } + + return ($suid); + +} + +sub _trango_access5830_sudbAddMac { + + my ($self, $action, $router) = (shift, shift, shift); + my ($svc_broadband) = shift; + my $old = shift if $action eq 'replace'; + + my $mac_addr = $svc_broadband->getfield($self->option('mac_field')); + $mac_addr = join('', $mac_addr =~ /[0-9a-fA-F]/g); + + # Sanity check. + die "Invalid Trango MAC address '$mac_addr'" unless (length($mac_addr)==12); + + return($mac_addr); + +} + + +=head1 BUGS + +Plenty, I'm sure. + +=cut + + +1; diff --git a/FS/FS/part_export/vpopmail.pm b/FS/FS/part_export/vpopmail.pm index 0fc8266ea..4cda65755 100644 --- a/FS/FS/part_export/vpopmail.pm +++ b/FS/FS/part_export/vpopmail.pm @@ -87,7 +87,7 @@ sub _export_delete { sub vpopmail_queue { my( $self, $svcnum, $method ) = (shift, shift, shift); - my $exportdir = "/usr/local/etc/freeside/export." . datasrc; + my $exportdir = "%%%FREESIDE_EXPORT%%%/export." . datasrc; mkdir $exportdir, 0700 or die $! unless -d $exportdir; $exportdir .= "/vpopmail"; mkdir $exportdir, 0700 or die $! unless -d $exportdir; diff --git a/FS/FS/part_export/www_plesk.pm b/FS/FS/part_export/www_plesk.pm new file mode 100644 index 000000000..82d555761 --- /dev/null +++ b/FS/FS/part_export/www_plesk.pm @@ -0,0 +1,138 @@ +package FS::part_export::www_plesk; + +use vars qw(@ISA %info); +use Tie::IxHash; +use FS::part_export; + +@ISA = qw(FS::part_export); + +tie my %options, 'Tie::IxHash', + 'URL' => { label=>'URL' }, + 'login' => { label=>'Login' }, + 'password' => { label=>'Password' }, + 'template' => { label=>'Domain Template' }, + 'web' => { label=>'Host Website', + type=>'checkbox' }, + 'debug' => { label=>'Enable debugging', + type=>'checkbox' }, +; + +%info = ( + 'svc' => 'svc_www', + 'desc' => 'Real-time export to Plesk managed hosting service', + 'options'=> \%options, + 'notes' => <<'END' +Real-time export to +<a href="http://www.swsoft.com/">Plesk</a> managed server. +Requires installation of +<a href="http://search.cpan.org/dist/Net-Plesk">Net::Plesk</a> +from CPAN. +END +); + +sub rebless { shift; } + +# experiment: want the status of these right away (don't want account to +# create or whatever and then get error in the queue from dup username or +# something), so no queueing + +sub _export_insert { + my( $self, $www ) = ( shift, shift ); + + eval "use Net::Plesk;"; + return $@ if $@; + + my $plesk = new Net::Plesk ( + 'POST' => $self->option('URL'), + ':HTTP_AUTH_LOGIN' => $self->option('login'), + ':HTTP_AUTH_PASSWD' => $self->option('password'), + ); + + my $gcresp = $plesk->client_get( $www->svc_acct->username ); + return $gcresp->errortext + unless $gcresp->is_success; + + unless ($gcresp->id) { + my $cust_main = $www->cust_svc->cust_pkg->cust_main; + $gcresp = $plesk->client_add( $cust_main->name, + $www->svc_acct->username, + $www->svc_acct->_password, + $cust_main->daytime, + $cust_main->fax, + $cust_main->invoicing_list->[0], + $cust_main->address1 . $cust_main->address2, + $cust_main->city, + $cust_main->state, + $cust_main->zip, + $cust_main->country, + ); + return $gcresp->errortext + unless $gcresp->is_success; + } + + $plesk->client_ippool_add_ip ( $gcresp->id, + $www->domain_record->recdata, + ); + + if ($self->option('web')) { + $self->_plesk_command( 'domain_add', + $www->domain_record->svc_domain->domain, + $gcresp->id, + $www->domain_record->recdata, + $self->option('template')?$self->option('template'):'', + $www->svc_acct->username, + $www->svc_acct->_password, + ); + }else{ + $self->_plesk_command( 'domain_add', + $www->domain_record->svc_domain->domain, + $gcresp->id, + $www->domain_record->recdata, + $self->option('template')?$self->option('template'):'', + ); + } +} + +sub _plesk_command { + my( $self, $method, @args ) = @_; + + eval "use Net::Plesk;"; + return $@ if $@; + + local($Net::Plesk::DEBUG) = 1 + if $self->option('debug'); + + my $plesk = new Net::Plesk ( + 'POST' => $self->option('URL'), + ':HTTP_AUTH_LOGIN' => $self->option('login'), + ':HTTP_AUTH_PASSWD' => $self->option('password'), + ); + + my $response = $plesk->$method(@args); + return $response->errortext unless $response->is_success; + ''; + +} + +sub _export_replace { + my( $self, $new, $old ) = (shift, shift, shift); + + return "can't change domain with Plesk" + if $old->domain_record->svc_domain->domain ne + $new->domain_record->svc_domain->domain; + + return "can't change client with Plesk" + if $old->svc_acct->username ne + $new->svc_acct->username; + + return ''; + +} + +sub _export_delete { + my( $self, $www ) = ( shift, shift ); + $self->_plesk_command( 'domain_del', $www->domain_record->svc_domain->domain); +} + +1; + diff --git a/FS/FS/part_pkg.pm b/FS/FS/part_pkg.pm index 73f3bae04..e4c13aade 100644 --- a/FS/FS/part_pkg.pm +++ b/FS/FS/part_pkg.pm @@ -1,7 +1,7 @@ package FS::part_pkg; use strict; -use vars qw( @ISA %freq %plans $DEBUG ); +use vars qw( @ISA %plans $DEBUG ); use Carp qw(carp cluck confess); use Tie::IxHash; use FS::Conf; @@ -12,8 +12,9 @@ use FS::cust_pkg; use FS::agent_type; use FS::type_pkgs; use FS::part_pkg_option; +use FS::pkg_class; -@ISA = qw( FS::Record ); # FS::option_Common ); # this can use option_Common +@ISA = qw( FS::m2m_Common FS::Record ); # FS::option_Common ); # this can use option_Common # when all the plandata bs is # gone @@ -58,6 +59,8 @@ inherits from FS::Record. The following fields are currently supported: =item comment - Text name of this package definition (non-customer-viewable) +=item classnum - Optional package class (see L<FS::pkg_class>) + =item promo_code - Promotional code =item setup - Setup fee expression (deprecated) @@ -78,6 +81,10 @@ inherits from FS::Record. The following fields are currently supported: =item disabled - Disabled flag, empty or `Y' +=item pay_weight - Weight (relative to credit_weight and other package definitions) that controls payment application to specific line items. + +=item credit_weight - Weight (relative to other package definitions) that controls credit application to specific line items. + =back =head1 METHODS @@ -304,6 +311,12 @@ FS::pkg_svc record will be updated. sub replace { my( $new, $old ) = ( shift, shift ); my %options = @_; + + # We absolutely have to have an old vs. new record to make this work. + if (!defined($old)) { + $old = qsearchs( 'part_pkg', { 'pkgpart' => $new->pkgpart } ); + } + warn "FS::part_pkg::replace called on $new to replace $old ". "with options %options" if $DEBUG; @@ -434,10 +447,19 @@ sub check { || $self->ut_enum('recurtax', [ '', 'Y' ] ) || $self->ut_textn('taxclass') || $self->ut_enum('disabled', [ '', 'Y' ] ) + || $self->ut_floatn('pay_weight') + || $self->ut_floatn('credit_weight') || $self->SUPER::check ; return $error if $error; + if ( $self->classnum !~ /^$/ ) { + my $error = $self->ut_foreign_key('classnum', 'pkg_class', 'classnum'); + return $error if $error; + } else { + $self->classnum(''); + } + return 'Unknown plan '. $self->plan unless exists($plans{$self->plan}); @@ -448,6 +470,37 @@ sub check { ''; } +=item pkg_class + +Returns the package class, as an FS::pkg_class object, or the empty string +if there is no package class. + +=cut + +sub pkg_class { + my $self = shift; + if ( $self->classnum ) { + qsearchs('pkg_class', { 'classnum' => $self->classnum } ); + } else { + return ''; + } +} + +=item classname + +Returns the package class name, or the empty string if there is no package +class. + +=cut + +sub classname { + my $self = shift; + my $pkg_class = $self->pkg_class; + $pkg_class + ? $pkg_class->classname + : ''; +} + =item pkg_svc Returns all FS::pkg_svc objects (see L<FS::pkg_svc>) for this package @@ -530,6 +583,34 @@ sub is_free { } } + +sub freqs_href { + #method, class method or sub? #my $self = shift; + + tie my %freq, 'Tie::IxHash', + '0' => '(no recurring fee)', + '1h' => 'hourly', + '1d' => 'daily', + '2d' => 'every two days', + '1w' => 'weekly', + '2w' => 'biweekly (every 2 weeks)', + '1' => 'monthly', + '45d' => 'every 45 days', + '2' => 'bimonthly (every 2 months)', + '3' => 'quarterly (every 3 months)', + '6' => 'semiannually (every 6 months)', + '12' => 'annually', + '24' => 'biannually (every 2 years)', + '36' => 'triannually (every 3 years)', + '48' => '(every 4 years)', + '60' => '(every 5 years)', + '120' => '(every 10 years)', + ; + + \%freq; + +} + =item freq_pretty Returns an english representation of the I<freq> field, such as "monthly", @@ -537,29 +618,15 @@ Returns an english representation of the I<freq> field, such as "monthly", =cut -tie %freq, 'Tie::IxHash', - '0' => '(no recurring fee)', - '1h' => 'hourly', - '1d' => 'daily', - '1w' => 'weekly', - '2w' => 'biweekly (every 2 weeks)', - '1' => 'monthly', - '2' => 'bimonthly (every 2 months)', - '3' => 'quarterly (every 3 months)', - '6' => 'semiannually (every 6 months)', - '12' => 'annually', - '24' => 'biannually (every 2 years)', - '36' => 'triannually (every 3 years)', - '48' => '(every 4 years)', - '60' => '(every 5 years)', - '120' => '(every 10 years)', -; - sub freq_pretty { my $self = shift; my $freq = $self->freq; - if ( exists($freq{$freq}) ) { - $freq{$freq}; + + #my $freqs_href = $self->freqs_href; + my $freqs_href = freqs_href(); + + if ( exists($freqs_href->{$freq}) ) { + $freqs_href->{$freq}; } else { my $interval = 'month'; if ( $freq =~ /^(\d+)([hdw])$/ ) { @@ -634,7 +701,8 @@ sub option { my %plandata = map { /^(\w+)=(.*)$/; ( $1 => $2 ); } split("\n", $self->get('plandata') ); return $plandata{$opt} if exists $plandata{$opt}; - cluck "Package definition option $opt not found in options or plandata!\n" + cluck "WARNING: (pkgpart ". $self->pkgpart. ") Package def option $opt ". + "not found in options or plandata!\n" unless $ornull; ''; } @@ -752,15 +820,16 @@ sub plan_info { =head1 NEW PLAN CLASSES -A module should be added in FS/FS/part_pkg/ (an example may be found in -eg/plan_template.pm) +A module should be added in FS/FS/part_pkg/ Eventually, an example may be +found in eg/plan_template.pm. Until then, it is suggested that you use the +other modules in FS/FS/part_pkg/ as a guide. =head1 BUGS The delete method is unimplemented. setup and recur semantics are not yet defined (and are implemented in -FS::cust_bill. hmm.). +FS::cust_bill. hmm.). now they're deprecated and need to go. plandata should go diff --git a/FS/FS/part_pkg/flat.pm b/FS/FS/part_pkg/flat.pm index 59b625746..94b7d9947 100644 --- a/FS/FS/part_pkg/flat.pm +++ b/FS/FS/part_pkg/flat.pm @@ -20,21 +20,61 @@ use FS::part_pkg; ' of service at cancellation', 'type' => 'checkbox', }, + 'externalid' => { 'name' => 'Optional External ID', + 'default' => '', + }, + 'seconds' => { 'name' => 'Time limit for this package', + 'default' => '', + }, + 'upbytes' => { 'name' => 'Upload limit for this package', + 'default' => '', + }, + 'downbytes' => { 'name' => 'Download limit for this package', + 'default' => '', + }, + 'totalbytes' => { 'name' => 'Transfer limit for this package', + 'default' => '', + }, + 'recharge_amount' => { 'name' => 'Cost of recharge for this package', + 'default' => '', + }, + 'recharge_seconds' => { 'name' => 'Recharge time for this package', + 'default' => '', + }, + 'recharge_upbytes' => { 'name' => 'Recharge upload for this package', + 'default' => '', + }, + 'recharge_downbytes' => { 'name' => 'Recharge download for this package', + 'default' => '', + }, + 'recharge_totalbytes' => { 'name' => 'Recharge transfer for this package', + 'default' => '', + }, }, - 'fieldorder' => [ 'setup_fee', 'recur_fee', 'unused_credit' ], - #'setup' => 'what.setup_fee.value', - #'recur' => 'what.recur_fee.value', + 'fieldorder' => [ 'setup_fee', 'recur_fee', 'unused_credit', + 'seconds', 'upbytes', 'downbytes', 'totalbytes', + 'recharge_amount', 'recharge_seconds', 'recharge_upbytes', + 'recharge_downbytes', 'recharge_totalbytes', + 'externalid' ], 'weight' => 10, ); sub calc_setup { - my($self, $cust_pkg ) = @_; + my($self, $cust_pkg, $sdate, $details ) = @_; + + my $i = 0; + my $count = $self->option( 'additional_count', 'quiet' ) || 0; + while ($i < $count) { + push @$details, $self->option( 'additional_info' . $i++ ); + } + $self->option('setup_fee'); } sub calc_recur { - my $self = shift; - $self->base_recur(@_); + my($self, $cust_pkg) = @_; + $self->reset_usage($cust_pkg); + $self->base_recur($cust_pkg); } sub base_recur { @@ -77,4 +117,12 @@ sub is_prepaid { 0; #no, we're postpaid } +sub reset_usage { + my($self, $cust_pkg) = @_; + my %values = map { $_, $self->option($_) } + grep { $self->option($_, 'hush') } + qw(seconds upbytes downbytes totalbytes); + $cust_pkg->set_usage(\%values); +} + 1; diff --git a/FS/FS/part_pkg/flat_comission.pm b/FS/FS/part_pkg/flat_comission.pm index 442415e08..bc02f9658 100644 --- a/FS/FS/part_pkg/flat_comission.pm +++ b/FS/FS/part_pkg/flat_comission.pm @@ -41,8 +41,14 @@ sub calc_recur { $cust_pkg->cust_main->referral_cust_pkg( $self->option('comission_depth') ) ); - my $error = $cust_pkg->cust_main->credit( $amount*$num_active, "commission" ); - die $error if $error; + my $commission = sprintf('%.2f', $amount*$num_active); + + if ( $commission > 0 ) { + + my $error = $cust_pkg->cust_main->credit( $commission, "commission" ); + die $error if $error; + + } $self->option('recur_fee'); } diff --git a/FS/FS/part_pkg/flat_delayed.pm b/FS/FS/part_pkg/flat_delayed.pm index ec11699d9..caade409e 100644 --- a/FS/FS/part_pkg/flat_delayed.pm +++ b/FS/FS/part_pkg/flat_delayed.pm @@ -20,12 +20,19 @@ use FS::part_pkg::flat; 'recur_fee' => { 'name' => 'Recurring fee for this package', 'default' => 0, }, + 'recur_notify' => { 'name' => 'Number of days before recurring billing'. + 'commences to notify customer. (0 means '. + 'no warning)', + 'default' => 0, + }, 'unused_credit' => { 'name' => 'Credit the customer for the unused portion'. ' of service at cancellation', 'type' => 'checkbox', }, }, - 'fieldorder' => [ 'free_days', 'setup_fee', 'recur_fee', 'unused_credit' ], + 'fieldorder' => [ 'free_days', 'setup_fee', 'recur_fee', 'recur_notify', + 'unused_credit' + ], #'setup' => '\'my $d = $cust_pkg->bill || $time; $d += 86400 * \' + what.free_days.value + \'; $cust_pkg->bill($d); $cust_pkg_mod_flag=1; \' + what.setup_fee.value', #'recur' => 'what.recur_fee.value', 'weight' => 50, diff --git a/FS/FS/part_pkg/flat_introrate.pm b/FS/FS/part_pkg/flat_introrate.pm new file mode 100644 index 000000000..c92ba978a --- /dev/null +++ b/FS/FS/part_pkg/flat_introrate.pm @@ -0,0 +1,67 @@ +package FS::part_pkg::flat_introrate; + +use strict; +use vars qw(@ISA %info $DEBUG $DEBUG_PRE); +#use FS::Record qw(qsearch qsearchs); +use FS::part_pkg::flat; + +use Date::Manip qw(DateCalc UnixDate ParseDate); + +@ISA = qw(FS::part_pkg::flat); +$DEBUG = 0; +$DEBUG_PRE = '[' . __PACKAGE__ . ']: '; + +%info = ( + 'name' => 'Introductory price for X months, then flat rate,'. + 'relative to setup date (anniversary billing)', + 'fields' => { + 'setup_fee' => { 'name' => 'Setup fee for this package', + 'default' => 0, + }, + 'intro_fee' => { 'name' => 'Introductory recurring free for this package', + 'default' => 0, + }, + 'intro_duration' => { 'name' => 'Duration of the introductory period, ' . + 'in number of months', + 'default' => 0, + }, + 'recur_fee' => { 'name' => 'Recurring fee for this package', + 'default' => 0, + }, + 'unused_credit' => { 'name' => 'Credit the customer for the unused portion'. + ' of service at cancellation', + 'type' => 'checkbox', + }, + }, + 'fieldorder' => [ 'setup_fee', 'intro_duration', 'intro_fee', 'recur_fee', 'unused_credit' ], + 'weight' => 150, +); + +sub calc_recur { + my($self, $cust_pkg, $time ) = @_; + + my ($duration) = ($self->option('intro_duration') =~ /^(\d+)$/); + unless ($duration) { + die "Invalid intro_duration: " . $self->option('intro_duration'); + } + + my $setup = &ParseDate('epoch ' . $cust_pkg->getfield('setup')); + my $intro_end = &DateCalc($setup, "+${duration} month"); + my $recur; + + warn $DEBUG_PRE . "\$duration = ${duration}" if $DEBUG; + warn $DEBUG_PRE . "\$intro_end = ${intro_end}" if $DEBUG; + warn $DEBUG_PRE . "$$time < " . &UnixDate($intro_end, '%s') if $DEBUG; + + if ($$time < &UnixDate($intro_end, '%s')) { + $recur = $self->option('intro_fee'); + } else { + $recur = $self->option('recur_fee'); + } + + $recur; + +} + + +1; diff --git a/FS/FS/part_pkg/incomplete/billoneday.pm b/FS/FS/part_pkg/incomplete/billoneday.pm new file mode 100644 index 000000000..8740547a3 --- /dev/null +++ b/FS/FS/part_pkg/incomplete/billoneday.pm @@ -0,0 +1,48 @@ +package FS::part_pkg::billoneday; + +use strict; +use vars qw(@ISA %info); +use Time::Local qw(timelocal); +#use FS::Record qw(qsearch qsearchs); +use FS::part_pkg::flat; + +@ISA = qw(FS::part_pkg::flat); + +%info = ( + 'name' => 'charge a full month every (selectable) billing day', + 'fields' => { + 'setup_fee' => { 'name' => 'Setup fee for this package', + 'default' => 0, + }, + 'recur_fee' => { 'name' => 'Recurring fee for this package', + 'default' => 0, + }, + 'cutoff_day' => { 'name' => 'billing day', + 'default' => 1, + }, + + }, + 'fieldorder' => [ 'setup_fee', 'recur_fee','cutoff_day'], + #'setup' => 'what.setup_fee.value', + #'recur' => '\'my $mnow = $sdate; my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($sdate) )[0,1,2,3,4,5]; $sdate = timelocal(0,0,0,$self->option('cutoff_day'),$mon,$year); \' + what.recur_fee.value', + 'freq' => 'm', + 'weight' => 30, +); + +sub calc_recur { + my($self, $cust_pkg, $sdate ) = @_; + + my $mnow = $$sdate; + my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($mnow) )[0,1,2,3,4,5]; + my $mstart = timelocal(0,0,0,$self->option('cutoff_day'),$mon,$year); + my $mend = timelocal(0,0,0,$self->option('cutoff_day'), $mon == 11 ? 0 : $mon+1, $year+($mon==11)); + + if($mday > $self->option('cutoff_date') and $mstart != $mnow ) { + $$sdate = timelocal(0,0,0,$self->option('cutoff_day'), $mon == 11 ? 0 : $mon+1, $year+($mon==11)); + } + else{ + $$sdate = timelocal(0,0,0,$self->option('cutoff_day'), $mon, $year); + } + $self->option('recur_fee'); +} +1; diff --git a/FS/FS/part_pkg/prepaid.pm b/FS/FS/part_pkg/prepaid.pm index 5e7d2baae..d309d453f 100644 --- a/FS/FS/part_pkg/prepaid.pm +++ b/FS/FS/part_pkg/prepaid.pm @@ -1,22 +1,32 @@ package FS::part_pkg::prepaid; use strict; -use vars qw(@ISA %info); +use vars qw(@ISA %info %recur_action); +use Tie::IxHash; use FS::part_pkg::flat; @ISA = qw(FS::part_pkg::flat); +tie %recur_action, 'Tie::IxHash', + 'suspend' => 'suspend', + 'cancel' => 'cancel', +; + %info = ( 'name' => 'Prepaid, flat rate', 'fields' => { - 'setup_fee' => { 'name' => 'One-time setup fee for this package', - 'default' => 0, - }, - 'recur_fee' => { 'name' => 'Initial and recharge fee for this package', - 'default' => 0, - } + 'setup_fee' => { 'name' => 'One-time setup fee for this package', + 'default' => 0, + }, + 'recur_fee' => { 'name' => 'Initial and recharge fee for this package', + 'default' => 0, + }, + 'recur_action' => { 'name' => 'Action to take upon reaching end of prepaid preiod', + 'type' => 'select', + 'select_options' => \%recur_action, + }, }, - 'fieldorder' => [ 'setup_fee', 'recur_fee', ], + 'fieldorder' => [ 'setup_fee', 'recur_fee', 'recur_action', ], 'weight' => 25, ); diff --git a/FS/FS/part_pkg/prorate.pm b/FS/FS/part_pkg/prorate.pm index 86c64d53a..7ce73647b 100644 --- a/FS/FS/part_pkg/prorate.pm +++ b/FS/FS/part_pkg/prorate.pm @@ -9,7 +9,7 @@ use FS::part_pkg::flat; @ISA = qw(FS::part_pkg::flat); %info = ( - 'name' => 'First partial month pro-rated, then flat-rate (1st of month billing)', + 'name' => 'First partial month pro-rated, then flat-rate (selectable billing day)', 'fields' => { 'setup_fee' => { 'name' => 'Setup fee for this package', 'default' => 0, @@ -21,22 +21,71 @@ use FS::part_pkg::flat; ' of service at cancellation', 'type' => 'checkbox', }, - }, - 'fieldorder' => [ 'setup_fee', 'recur_fee', 'unused_credit' ], - #'setup' => 'what.setup_fee.value', - #'recur' => '\'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 ) * \' + what.recur_fee.value + \' / $part_pkg->freq + \' + what.recur_fee.value + \' / $part_pkg->freq * ($mend-$mnow) / ($mend-$mstart) ; \'', + 'cutoff_day' => { 'name' => 'billing day', + 'default' => 1, + }, + 'seconds' => { 'name' => 'Time limit for this package', + 'default' => '', + }, + 'upbytes' => { 'name' => 'Upload limit for this package', + 'default' => '', + }, + 'downbytes' => { 'name' => 'Download limit for this package', + 'default' => '', + }, + 'totalbytes' => { 'name' => 'Transfer limit for this package', + 'default' => '', + }, + 'recharge_amount' => { 'name' => 'Cost of recharge for this package', + 'default' => '', + }, + 'recharge_seconds' => { 'name' => 'Recharge time for this package', + 'default' => '', + }, + 'recharge_upbytes' => { 'name' => 'Recharge upload for this package', + 'default' => '', + }, + 'recharge_downbytes' => { 'name' => 'Recharge download for this package', 'default' => '', + }, + 'recharge_totalbytes' => { 'name' => 'Recharge transfer for this package', 'default' => '', + }, + #it would be better if this had to be turned on, its confusing + 'externalid' => { 'name' => 'Optional External ID', + 'default' => '', + }, + }, + 'fieldorder' => [ 'setup_fee', 'recur_fee', 'unused_credit', 'cutoff_day', + 'seconds', 'upbyte', 'downbytes', 'totalbytes', + 'recharge_amount', 'recharge_seconds', 'recharge_upbytes', + 'recharge_downbytes', 'recharge_totalbytes', + 'externalid', ], 'freq' => 'm', 'weight' => 20, ); sub calc_recur { my($self, $cust_pkg, $sdate ) = @_; + my $cutoff_day = $self->option('cutoff_day', 1) || 1; my $mnow = $$sdate; my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($mnow) )[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; + my $mend; + my $mstart; + + $self->reset_usage($cust_pkg); + if ( $mday >= $cutoff_day ) { + $mend = + timelocal(0,0,0,$cutoff_day, $mon == 11 ? 0 : $mon+1, $year+($mon==11)); + $mstart = + timelocal(0,0,0,$cutoff_day,$mon,$year); + + } else { + $mend = timelocal(0,0,0,$cutoff_day, $mon, $year); + if ($mon==0) {$mon=11;$year--;} else {$mon--;} + $mstart= timelocal(0,0,0,$cutoff_day,$mon,$year); + } + + $$sdate = $mstart; my $permonth = $self->option('recur_fee') / $self->freq; $permonth * ( ( $self->freq - 1 ) + ($mend-$mnow) / ($mend-$mstart) ); diff --git a/FS/FS/part_pkg/subscription.pm b/FS/FS/part_pkg/subscription.pm index 36b5a96fb..db04842f5 100644 --- a/FS/FS/part_pkg/subscription.pm +++ b/FS/FS/part_pkg/subscription.pm @@ -9,28 +9,75 @@ use FS::part_pkg::flat; @ISA = qw(FS::part_pkg::flat); %info = ( - 'name' => 'First partial month full charge, then flat-rate (1st of month billing)', + 'name' => 'First partial month full charge, then flat-rate (selectable billing day)', 'fields' => { 'setup_fee' => { 'name' => 'Setup fee for this package', 'default' => 0, }, 'recur_fee' => { 'name' => 'Recurring fee for this package', 'default' => 0, - }, + }, + 'cutoff_day' => { 'name' => 'billing day', + 'default' => 1, + }, + 'seconds' => { 'name' => 'Time limit for this package', + 'default' => '', + }, + 'upbytes' => { 'name' => 'Upload limit for this package', + 'default' => '', + }, + 'downbytes' => { 'name' => 'Download limit for this package', + 'default' => '', + }, + 'totalbytes' => { 'name' => 'Transfer limit for this package', + 'default' => '', + }, + 'recharge_amount' => { 'name' => 'Cost of recharge for this package', + 'default' => '', + }, + 'recharge_seconds' => { 'name' => 'Recharge time for this package', + 'default' => '', + }, + 'recharge_upbytes' => { 'name' => 'Recharge upload for this package', + 'default' => '', + }, + 'recharge_downbytes' => { 'name' => 'Recharge download for this package', 'default' => '', + }, + 'recharge_totalbytes' => { 'name' => 'Recharge transfer for this package', 'default' => '', + }, + #it would be better if this had to be turned on, its confusing + 'externalid' => { 'name' => 'Optional External ID', + 'default' => '', + }, }, - 'fieldorder' => [ 'setup_fee', 'recur_fee' ], - #'setup' => 'what.setup_fee.value', - #'recur' => '\'my $mnow = $sdate; my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($sdate) )[0,1,2,3,4,5]; $sdate = timelocal(0,0,0,1,$mon,$year); \' + what.recur_fee.value', + 'fieldorder' => [ 'setup_fee', 'recur_fee', 'cutoff_day', 'seconds', + 'upbytes', 'downbytes', 'totalbytes', + 'recharge_amount', 'recharge_seconds', 'recharge_upbytes', + 'recharge_downbytes', 'recharge_totalbytes', + 'externalid' ], + 'fieldorder' => [ 'setup_fee', 'recur_fee','cutoff_day', 'seconds', + 'upbytes', 'downbytes', 'totalbytes', + 'recharge_amount', 'recharge_seconds', 'recharge_upbytes', + 'recharge_downbytes', 'recharge_totalbytes', + ], 'freq' => 'm', 'weight' => 30, ); sub calc_recur { my($self, $cust_pkg, $sdate ) = @_; - + my $cutoff_day = $self->option('cutoff_day', 1) || 1; my $mnow = $$sdate; my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($mnow) )[0,1,2,3,4,5]; - $$sdate = timelocal(0,0,0,1,$mon,$year); + + if ( $mday < $cutoff_day ) { + if ($mon==0) {$mon=11;$year--;} + else {$mon--;} + } + + $$sdate = timelocal(0,0,0,$cutoff_day,$mon,$year); + + $self->reset_usage($cust_pkg); $self->option('recur_fee'); } diff --git a/FS/FS/part_pkg/voip_cdr.pm b/FS/FS/part_pkg/voip_cdr.pm new file mode 100644 index 000000000..500a1b0a4 --- /dev/null +++ b/FS/FS/part_pkg/voip_cdr.pm @@ -0,0 +1,353 @@ +package FS::part_pkg::voip_cdr; + +use strict; +use vars qw(@ISA $DEBUG %info); +use Date::Format; +use Tie::IxHash; +use FS::Conf; +use FS::Record qw(qsearchs qsearch); +use FS::part_pkg::flat; +#use FS::rate; +#use FS::rate_prefix; + +@ISA = qw(FS::part_pkg::flat); + +$DEBUG = 1; + +tie my %rating_method, 'Tie::IxHash', + 'prefix' => 'Rate calls by using destination prefix to look up a region and rate according to the internal prefix and rate tables', + 'upstream' => 'Rate calls based on upstream data: If the call type is "1", map the upstream rate ID directly to an internal rate (rate_detail), otherwise, pass the upstream price through directly.', +; + +#tie my %cdr_location, 'Tie::IxHash', +# 'internal' => 'Internal: CDR records imported into the internal CDR table', +# 'external' => 'External: CDR records queried directly from an external '. +# 'Asterisk (or other?) CDR table', +#; + +%info = ( + 'name' => 'VoIP rating by plan of CDR records in an internal (or external?) SQL table', + 'fields' => { + 'setup_fee' => { 'name' => 'Setup fee for this package', + 'default' => 0, + }, + 'recur_flat' => { 'name' => 'Base recurring fee for this package', + 'default' => 0, + }, + 'unused_credit' => { 'name' => 'Credit the customer for the unused portion'. + ' of service at cancellation', + 'type' => 'checkbox', + }, + 'ratenum' => { 'name' => 'Rate plan', + 'type' => 'select', + 'select_table' => 'rate', + 'select_key' => 'ratenum', + 'select_label' => 'ratename', + }, + 'rating_method' => { 'name' => 'Region rating method', + 'type' => 'select', + 'select_options' => \%rating_method, + }, + + 'default_prefix' => { 'name' => 'Default prefix optionally prepended to customer DID numbers when searching for CDR records', + 'default' => '+1', + }, + + #XXX also have option for an external db?? +# 'cdr_location' => { 'name' => 'CDR database location' +# 'type' => 'select', +# 'select_options' => \%cdr_location, +# 'select_callback' => { +# 'external' => { +# 'enable' => [ 'datasrc', 'username', 'password' ], +# }, +# 'internal' => { +# 'disable' => [ 'datasrc', 'username', 'password' ], +# } +# }, +# }, +# 'datasrc' => { 'name' => 'DBI data source for external CDR table', +# 'disabled' => 'Y', +# }, +# 'username' => { 'name' => 'External database username', +# 'disabled' => 'Y', +# }, +# 'password' => { 'name' => 'External database password', +# 'disabled' => 'Y', +# }, + + }, + 'fieldorder' => [qw( setup_fee recur_flat unused_credit ratenum rating_method default_prefix )], + 'weight' => 40, +); + +sub calc_setup { + my($self, $cust_pkg ) = @_; + $self->option('setup_fee'); +} + +#false laziness w/voip_sqlradacct... resolve it if that one ever gets used again +sub calc_recur { + my($self, $cust_pkg, $sdate, $details, $param ) = @_; + + my $last_bill = $cust_pkg->last_bill; + + my $ratenum = $cust_pkg->part_pkg->option('ratenum'); + + my $spool_cdr = $cust_pkg->cust_main->spool_cdr; + + my %included_min = (); + + my $charges = 0; + + my $downstream_cdr = ''; + + foreach my $cust_svc ( + grep { $_->part_svc->svcdb eq 'svc_phone' } $cust_pkg->cust_svc + ) { + + foreach my $cdr ( + $cust_svc->get_cdrs_for_update() # $last_bill, $$sdate ) + ) { + if ( $DEBUG > 1 ) { + warn "rating CDR $cdr\n". + join('', map { " $_ => ". $cdr->{$_}. "\n" } keys %$cdr ); + } + + my $rate_detail; + my( $rate_region, $regionnum ); + my $pretty_destnum; + my $charge = 0; + my @call_details = (); + if ( $self->option('rating_method') eq 'prefix' + || ! $self->option('rating_method') + ) + { + + ### + # look up rate details based on called station id + # (or calling station id for toll free calls) + ### + + my( $to_or_from, $number ); + if ( $cdr->dst =~ /^(\+?1)?8[02-8]{2}/ ) { #tollfree call + $to_or_from = 'from'; + $number = $cdr->src; + } else { #regular call + $to_or_from = 'to'; + $number = $cdr->dst; + } + + #remove non-phone# stuff and whitespace + $number =~ s/\s//g; +# my $proto = ''; +# $dest =~ s/^(\w+):// and $proto = $1; #sip: +# my $siphost = ''; +# $dest =~ s/\@(.*)$// and $siphost = $1; # @10.54.32.1, @sip.example.com + + #determine the country code + my $countrycode; + if ( $number =~ /^011(((\d)(\d))(\d))(\d+)$/ + || $number =~ /^\+(((\d)(\d))(\d))(\d+)$/ + ) + { + + my( $three, $two, $one, $u1, $u2, $rest ) = ( $1,$2,$3,$4,$5,$6 ); + #first look for 1 digit country code + if ( qsearch('rate_prefix', { 'countrycode' => $one } ) ) { + $countrycode = $one; + $number = $u1.$u2.$rest; + } elsif ( qsearch('rate_prefix', { 'countrycode' => $two } ) ) { #or 2 + $countrycode = $two; + $number = $u2.$rest; + } else { #3 digit country code + $countrycode = $three; + $number = $rest; + } + + } else { + $countrycode = '1'; + $number =~ s/^1//;# if length($number) > 10; + } + + warn "rating call $to_or_from +$countrycode $number\n" if $DEBUG; + $pretty_destnum = "+$countrycode $number"; + + #find a rate prefix, first look at most specific (4 digits) then 3, etc., + # finally trying the country code only + my $rate_prefix = ''; + for my $len ( reverse(1..6) ) { + $rate_prefix = qsearchs('rate_prefix', { + 'countrycode' => $countrycode, + #'npa' => { op=> 'LIKE', value=> substr($number, 0, $len) } + 'npa' => substr($number, 0, $len), + } ) and last; + } + $rate_prefix ||= qsearchs('rate_prefix', { + 'countrycode' => $countrycode, + 'npa' => '', + }); + + # + die "Can't find rate for call $to_or_from +$countrycode $\numbern" + unless $rate_prefix; + + $regionnum = $rate_prefix->regionnum; + $rate_detail = qsearchs('rate_detail', { + 'ratenum' => $ratenum, + 'dest_regionnum' => $regionnum, + } ); + + $rate_region = $rate_prefix->rate_region; + + warn " found rate for regionnum $regionnum ". + "and rate detail $rate_detail\n" + if $DEBUG; + + } elsif ( $self->option('rating_method') eq 'upstream' ) { + + if ( $cdr->cdrtypenum == 1 ) { #rate based on upstream rateid + + $rate_detail = $cdr->cdr_upstream_rate->rate_detail; + + $regionnum = $rate_detail->dest_regionnum; + $rate_region = $rate_detail->dest_region; + + $pretty_destnum = $cdr->dst; + + warn " found rate for regionnum $regionnum and ". + "rate detail $rate_detail\n" + if $DEBUG; + + } else { #pass upstream price through + + $charge = sprintf('%.2f', $cdr->upstream_price); + + @call_details = ( + #time2str("%Y %b %d - %r", $cdr->calldate_unix ), + time2str("%c", $cdr->calldate_unix), #XXX this should probably be a config option dropdown so they can select US vs- rest of world dates or whatnot + 'N/A', #minutes... + '$'.$charge, + #$pretty_destnum, + $cdr->description, #$rate_region->regionname, + ); + + } + + } else { + die "don't know how to rate CDRs using method: ". + $self->option('rating_method'). "\n"; + } + + ### + # find the price and add detail to the invoice + ### + + # if $rate_detail is not found, skip this CDR... i.e. + # don't add it to invoice, don't set its status to NULL, + # don't call downstream_csv or something on it... + # but DO emit a warning... + if ( ! $rate_detail && ! scalar(@call_details) ) { + + warn "no rate_detail found for CDR.acctid: ". $cdr->acctid. + "; skipping\n" + + } else { # there *is* a rate_detail (or call_details), proceed... + + unless ( @call_details ) { + + $included_min{$regionnum} = $rate_detail->min_included + unless exists $included_min{$regionnum}; + + my $granularity = $rate_detail->sec_granularity; + my $seconds = $cdr->billsec; # |ength($cdr->billsec) ? $cdr->billsec : $cdr->duration; + $seconds += $granularity - ( $seconds % $granularity ); + my $minutes = sprintf("%.1f", $seconds / 60); + $minutes =~ s/\.0$// if $granularity == 60; + + $included_min{$regionnum} -= $minutes; + + if ( $included_min{$regionnum} < 0 ) { + my $charge_min = 0 - $included_min{$regionnum}; + $included_min{$regionnum} = 0; + $charge = sprintf('%.2f', $rate_detail->min_charge * $charge_min ); + $charges += $charge; + } + + # this is why we need regionnum/rate_region.... + warn " (rate region $rate_region)\n" if $DEBUG; + + @call_details = ( + #time2str("%Y %b %d - %r", $cdr->calldate_unix ), + time2str("%c", $cdr->calldate_unix), #XXX this should probably be a config option dropdown so they can select US vs- rest of world dates or whatnot + $minutes.'m', + '$'.$charge, + $pretty_destnum, + $rate_region->regionname, + ); + + } + + warn " adding details on charge to invoice: ". + join(' - ', @call_details ) + if $DEBUG; + + push @$details, join(' - ', @call_details); #\@call_details, + + # if the customer flag is on, call "downstream_csv" or something + # like it to export the call downstream! + # XXX price plan option to pick format, or something... + $downstream_cdr .= $cdr->downstream_csv( 'format' => 'convergent' ) + if $spool_cdr; + + my $error = $cdr->set_status_and_rated_price('done', $charge); + die $error if $error; + + } + + } # $cdr + + } # $cust_svc + + if ( $spool_cdr && length($downstream_cdr) ) { + + use FS::UID qw(datasrc); + my $dir = '/usr/local/etc/freeside/export.'. datasrc. '/cdr'; + mkdir $dir, 0700 unless -d $dir; + $dir .= '/'. $cust_pkg->custnum. + mkdir $dir, 0700 unless -d $dir; + my $filename = time2str("$dir/CDR%Y%m%d-spool.CSV", time); #XXX invoice date instead? would require changing the order things are generated in cust_main::bill insert cust_bill first - with transactions it could be done though + + push @{ $param->{'precommit_hooks'} }, + sub { + #lock the downstream spool file and append the records + use Fcntl qw(:flock); + use IO::File; + my $spool = new IO::File ">>$filename" + or die "can't open $filename: $!\n"; + flock( $spool, LOCK_EX) + or die "can't lock $filename: $!\n"; + seek($spool, 0, 2) + or die "can't seek to end of $filename: $!\n"; + print $spool $downstream_cdr; + flock( $spool, LOCK_UN ); + close $spool; + }; + + } #if ( $spool_cdr && length($downstream_cdr) ) + + $self->option('recur_flat') + $charges; + +} + +sub is_free { + 0; +} + +sub base_recur { + my($self, $cust_pkg) = @_; + $self->option('recur_flat'); +} + +1; + diff --git a/FS/FS/part_pkg/voip_sqlradacct.pm b/FS/FS/part_pkg/voip_sqlradacct.pm index fd9c1ddb5..bf18003ab 100644 --- a/FS/FS/part_pkg/voip_sqlradacct.pm +++ b/FS/FS/part_pkg/voip_sqlradacct.pm @@ -41,6 +41,7 @@ sub calc_setup { $self->option('setup_fee'); } +#false laziness w/voip_cdr... resolve it if this one ever gets used again sub calc_recur { my($self, $cust_pkg, $sdate, $details ) = @_; diff --git a/FS/FS/part_referral.pm b/FS/FS/part_referral.pm index c0858c0ed..87bc87cba 100644 --- a/FS/FS/part_referral.pm +++ b/FS/FS/part_referral.pm @@ -2,7 +2,8 @@ package FS::part_referral; use strict; use vars qw( @ISA ); -use FS::Record; +use FS::Record qw( qsearch qsearchs dbh ); +use FS::agent; @ISA = qw( FS::Record ); @@ -40,6 +41,8 @@ The following fields are currently supported: =item disabled - Disabled flag, empty or 'Y' +=item agentnum - Optional agentnum (see L<FS::agent>) + =back =head1 NOTE @@ -95,17 +98,92 @@ sub check { my $error = $self->ut_numbern('refnum') || $self->ut_text('referral') + || $self->ut_enum('disabled', [ '', 'Y' ] ) + #|| $self->ut_foreign_keyn('agentnum', 'agent', 'agentnum') + || $self->ut_agentnum_acl('agentnum', 'Edit global advertising sources') ; return $error if $error; - if ( $self->dbdef_table->column('disabled') ) { - $error = $self->ut_enum('disabled', [ '', 'Y' ] ); - return $error if $error; - } - $self->SUPER::check; } +=item agent + +Returns the associated agent for this referral, if any, as an FS::agent object. + +=cut + +sub agent { + my $self = shift; + qsearchs('agent', { 'agentnum' => $self->agentnum } ); +} + +=back + +=head1 CLASS METHODS + +=over 4 + +=item acl_agentnum_sql [ INCLUDE_GLOBAL_BOOL ] + +Returns an SQL fragment for searching for part_referral records allowed by the +current users's agent ACLs (and "Edit global advertising sources" right). + +Pass a true value to include global advertising sources (for example, when +simply using rather than editing advertising sources). + +=cut + +sub acl_agentnum_sql { + my $self = shift; + + my $curuser = $FS::CurrentUser::CurrentUser; + my $sql = $curuser->agentnums_sql; + $sql = " ( $sql OR agentnum IS NULL ) " + if $curuser->access_right('Edit global advertising sources') + or defined($_[0]) && $_[0]; + + $sql; + +} + +=item all_part_referral [ INCLUDE_GLOBAL_BOOL ] + +Returns all part_referral records allowed by the current users's agent ACLs +(and "Edit global advertising sources" right). + +Pass a true value to include global advertising sources (for example, when +simply using rather than editing advertising sources). + +=cut + +sub all_part_referral { + my $self = shift; + + qsearch({ + 'table' => 'part_referral', + 'extra_sql' => ' WHERE '. $self->acl_agentnum_sql(@_). ' ORDER BY refnum ', + }); + +} + +=item num_part_referral [ INCLUDE_GLOBAL_BOOL ] + +Returns the number of part_referral records allowed by the current users's +agent ACLs (and "Edit global advertising sources" right). + +=cut + +sub num_part_referral { + my $self = shift; + + my $sth = dbh->prepare( + 'SELECT COUNT(*) FROM part_referral WHERE '. $self->acl_agentnum_sql(@_) + ) or die dbh->errstr; + $sth->execute() or die $sth->errstr; + $sth->fetchrow_arrayref->[0]; +} + =back =head1 BUGS diff --git a/FS/FS/part_svc.pm b/FS/FS/part_svc.pm index 1a478a9cd..5b4e54cc2 100644 --- a/FS/FS/part_svc.pm +++ b/FS/FS/part_svc.pm @@ -2,6 +2,7 @@ package FS::part_svc; use strict; use vars qw( @ISA $DEBUG ); +use Tie::IxHash; use FS::Record qw( qsearch qsearchs fields dbh ); use FS::Schema qw( dbdef ); use FS::part_svc_column; @@ -79,7 +80,7 @@ the part_svc_column table appropriately (see L<FS::part_svc_column>). =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. For virtual fields, can also be 'X' for excluded. +=item I<svcdb>__I<field>_flag - defines I<svcdb>__I<field> action: null or empty (no default), `D' for default, `F' for fixed (unchangeable), `M' for manual selection from inventory, or `A' for automatic selection from inventory. For virtual fields, can also be 'X' for excluded. =back @@ -142,7 +143,8 @@ sub insert { } ); my $flag = $self->getfield($svcdb.'__'.$field.'_flag'); - if ( uc($flag) =~ /^([DFX])$/ ) { + #if ( uc($flag) =~ /^([DFMAX])$/ ) { + if ( uc($flag) =~ /^([A-Z])$/ ) { #part_svc_column will test it $part_svc_column->setfield('columnflag', $1); $part_svc_column->setfield('columnvalue', $self->getfield($svcdb.'__'.$field) @@ -260,7 +262,8 @@ sub replace { } ); my $flag = $new->getfield($svcdb.'__'.$field.'_flag'); - if ( uc($flag) =~ /^([DFX])$/ ) { + #if ( uc($flag) =~ /^([DFMAX])$/ ) { + if ( uc($flag) =~ /^([A-Z])$/ ) { #part_svc_column will test it $part_svc_column->setfield('columnflag', $1); $part_svc_column->setfield('columnvalue', $new->getfield($svcdb.'__'.$field) @@ -345,7 +348,6 @@ and replace methods. sub check { my $self = shift; - my $recref = $self->hashref; my $error; $error= @@ -356,8 +358,9 @@ sub check { ; return $error if $error; - my @fields = eval { fields( $recref->{svcdb} ) }; #might die - return "Unknown svcdb!" unless @fields; + my @fields = eval { fields( $self->svcdb ) }; #might die + return "Unknown svcdb: ". $self->svcdb. " (Error: $@)" + unless @fields; $self->SUPER::check; } @@ -498,6 +501,161 @@ sub svc_x { map { $_->svc_x } $self->cust_svc; } +=back + +=head1 CLASS METHODS + +=over 4 + +=cut + +my $svc_defs; +sub _svc_defs { + + return $svc_defs if $svc_defs; #cache + + my $conf = new FS::Conf; + + #false laziness w/part_pkg.pm::plan_info + + my %info; + foreach my $INC ( @INC ) { + warn "globbing $INC/FS/svc_*.pm\n" if $DEBUG; + foreach my $file ( glob("$INC/FS/svc_*.pm") ) { + + warn "attempting to load service table info from $file\n" if $DEBUG; + $file =~ /\/(\w+)\.pm$/ or do { + warn "unrecognized file in $INC/FS/: $file\n"; + next; + }; + my $mod = $1; + + if ( $mod =~ /^svc_[A-Z]/ or $mod =~ /^svc_acct_pop$/ ) { + warn "skipping FS::$mod" if $DEBUG; + next; + } + + eval "use FS::$mod;"; + if ( $@ ) { + die "error using FS::$mod (skipping): $@\n" if $@; + next; + } + unless ( UNIVERSAL::can("FS::$mod", 'table_info') ) { + warn "FS::$mod has no table_info method; skipping"; + next; + } + + my $info = "FS::$mod"->table_info; + unless ( keys %$info ) { + warn "FS::$mod->table_info doesn't return info, skipping\n"; + next; + } + warn "got info from FS::$mod: $info\n" if $DEBUG; + if ( exists($info->{'disabled'}) && $info->{'disabled'} ) { + warn "skipping disabled service FS::$mod" if $DEBUG; + next; + } + $info{$mod} = $info; + } + } + + tie my %svc_defs, 'Tie::IxHash', + map { $_ => $info{$_}->{'fields'} } + sort { $info{$a}->{'display_weight'} <=> $info{$b}->{'display_weight'} } + keys %info, + ; + + # yuck. maybe this won't be so bad when virtual fields become real fields + my %vfields; + foreach my $svcdb (grep dbdef->table($_), keys %svc_defs ) { + eval "use FS::$svcdb;"; + my $self = "FS::$svcdb"->new; + $vfields{$svcdb} = {}; + foreach my $field ($self->virtual_fields) { # svc_Common::virtual_fields with a null svcpart returns all of them + my $pvf = $self->pvf($field); + my @list = $pvf->list; + if (scalar @list) { + $svc_defs{$svcdb}->{$field} = { desc => $pvf->label, + type => 'select', + select_list => \@list }; + } else { + $svc_defs{$svcdb}->{$field} = $pvf->label; + } #endif + $vfields{$svcdb}->{$field} = $pvf; + warn "\$vfields{$svcdb}->{$field} = $pvf" + if $DEBUG; + } #next $field + } #next $svcdb + + $svc_defs = \%svc_defs; #cache + +} + +=item svc_tables + +Returns a list of all svc_ tables. + +=cut + +sub svc_tables { + my $class = shift; + my $svc_defs = $class->_svc_defs; + grep { defined( dbdef->table($_) ) } keys %$svc_defs; +} + +=item svc_table_fields TABLE + +Given a table name, returns a hashref of field names. The field names +returned are those with additional (service-definition related) information, +not necessarily all database fields of the table. Pseudo-fields may also +be returned (i.e. svc_acct.usergroup). + +Each value of the hashref is another hashref, which can have one or more of +the following keys: + +=over 4 + +=item label - Description of the field + +=item def_label - Optional description of the field in the context of service definitions + +=item type - Currently "text", "select", "disabled", or "radius_usergroup_selector" + +=item disable_default - This field should not allow a default value in service definitions + +=item disable_fixed - This field should not allow a fixed value in service definitions + +=item disable_inventory - This field should not allow inventory values in service definitions + +=item select_list - If type is "text", this can be a listref of possible values. + +=item select_table - An alternative to select_list, this defines a database table with the possible choices. + +=item select_key - Used with select_table, this is the field name of keys + +=item select_label - Used with select_table, this is the field name of labels + +=back + +=cut + +#maybe this should move and be a class method in svc_Common.pm +sub svc_table_fields { + my($class, $table) = @_; + my $svc_defs = $class->_svc_defs; + my $def = $svc_defs->{$table}; + + foreach ( grep !ref($def->{$_}), keys %$def ) { + + #normalize the shortcut in %info hash + $def->{$_} = { 'label' => $def->{$_} }; + + $def->{$_}{'type'} ||= 'text'; + + } + + $def; +} =back @@ -536,9 +694,23 @@ sub process { map { my $svcdb = $_; my @fields = fields($svcdb); push @fields, 'usergroup' if $svcdb eq 'svc_acct'; #kludge - map { ( $svcdb.'__'.$_, $svcdb.'__'.$_.'_flag' ) } @fields; - } grep defined( dbdef->table($_) ), - qw( svc_acct svc_domain svc_forward svc_www svc_broadband ) + + map { + if ( $param->{ $svcdb.'__'.$_.'_flag' } =~ /^[MA]$/ ) { + $param->{ $svcdb.'__'.$_ } = + delete( $param->{ $svcdb.'__'.$_.'_classnum' } ); + } + if ( $param->{ $svcdb.'__'.$_.'_flag' } =~ /^S$/ ) { + $param->{ $svcdb.'__'.$_} = + ref($param->{ $svcdb.'__'.$_}) + ? join(',', @{$param->{ $svcdb.'__'.$_ }} ) + : $param->{ $svcdb.'__'.$_ }; + } + ( $svcdb.'__'.$_, $svcdb.'__'.$_.'_flag' ); + } + @fields; + + } FS::part_svc->svc_tables() ) } ); @@ -632,8 +804,8 @@ sub process_bulk_cust_svc { Delete is unimplemented. -The list of svc_* tables is hardcoded. When svc_acct_pop is renamed, this -should be fixed. +The list of svc_* tables is no longer hardcoded, but svc_acct_pop is skipped +as a special case until it is renamed. all_part_svc_column methods should be documented diff --git a/FS/FS/part_svc_column.pm b/FS/FS/part_svc_column.pm index 0450b35ef..d2b8fd91b 100644 --- a/FS/FS/part_svc_column.pm +++ b/FS/FS/part_svc_column.pm @@ -41,7 +41,7 @@ fields are currently supported: =item columnvalue - default or fixed value for the column -=item columnflag - null, D, F, X (virtual fields) +=item columnflag - null or empty (no default), `D' for default, `F' for fixed (unchangeable), `S' for selectable choice, `M' for manual selection from inventory, or `A' for automatic selection from inventory. For virtual fields, can also be 'X' for excluded. =back @@ -91,10 +91,16 @@ sub check { ; return $error if $error; - $self->columnflag =~ /^([DFX])$/ + $self->columnflag =~ /^([DFSMAX])$/ or return "illegal columnflag ". $self->columnflag; $self->columnflag(uc($1)); + if ( $self->columnflag =~ /^[MA]$/ ) { + $error = + $self->ut_foreign_key( 'columnvalue', 'inventory_class', 'classnum' ); + return $error if $error; + } + $self->SUPER::check; } diff --git a/FS/FS/pay_batch.pm b/FS/FS/pay_batch.pm new file mode 100644 index 000000000..add4da9e0 --- /dev/null +++ b/FS/FS/pay_batch.pm @@ -0,0 +1,486 @@ +package FS::pay_batch; + +use strict; +use vars qw( @ISA ); +use Time::Local; +use Text::CSV_XS; +use FS::Record qw( dbh qsearch qsearchs ); +use FS::cust_pay; +use FS::part_bill_event qw(due_events); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::pay_batch - Object methods for pay_batch records + +=head1 SYNOPSIS + + use FS::pay_batch; + + $record = new FS::pay_batch \%hash; + $record = new FS::pay_batch { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::pay_batch object represents an example. FS::pay_batch inherits from +FS::Record. The following fields are currently supported: + +=over 4 + +=item batchnum - primary key + +=item payby - CARD or CHEK + +=item status - O (Open), I (In-transit), or R (Resolved) + +=item download - + +=item upload - + + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new example. To add the example to the database, see L<"insert">. + +Note that this stores the hash reference, not a distinct copy of the hash it +points to. You can ask the object for a copy with the I<hash> method. + +=cut + +# the new method can be inherited from FS::Record, if a table method is defined + +sub table { 'pay_batch'; } + +=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('batchnum') + || $self->ut_enum('payby', [ 'CARD', 'CHEK' ]) + || $self->ut_enum('status', [ 'O', 'I', 'R' ]) + ; + return $error if $error; + + $self->SUPER::check; +} + +=item rebalance + +=cut + +sub rebalance { + my $self = shift; +} + +=item set_status + +=cut + +sub set_status { + my $self = shift; + $self->status(shift); + $self->download(time) + if $self->status eq 'I' && ! $self->download; + $self->upload(time) + if $self->status eq 'R' && ! $self->upload; + $self->replace(); +} + +=item import results OPTION => VALUE, ... + +Import batch results. + +Options are: + +I<filehandle> - open filehandle of results file. + +I<format> - "csv-td_canada_trust-merchant_pc_batch", "csv-chase_canada-E-xactBatch" or "PAP" + +=cut + +sub import_results { + my $self = shift; + + my $param = ref($_[0]) ? shift : { @_ }; + my $fh = $param->{'filehandle'}; + my $format = $param->{'format'}; + + my $filetype; # CSV, Fixed80, Fixed264 + my @fields; + my $formatre; # for Fixed.+ + my @values; + my $begin_condition; + my $end_condition; + my $end_hook; + my $hook; + my $approved_condition; + my $declined_condition; + + if ( $format eq 'csv-td_canada_trust-merchant_pc_batch' ) { + + $filetype = "CSV"; + + @fields = ( + 'paybatchnum', # Reference#: Invoice number of the transaction + 'paid', # Amount: Amount of the transaction. Dollars and cents + # with no decimal entered. + '', # Card Type: 0 - MCrd, 1 - Visa, 2 - AMEX, 3 - Discover, + # 4 - Insignia, 5 - Diners/EnRoute, 6 - JCB + '_date', # Transaction Date: Date the Transaction was processed + 'time', # Transaction Time: Time the transaction was processed + 'payinfo', # Card Number: Card number for the transaction + '', # Expiry Date: Expiry date of the card + '', # Auth#: Authorization number entered for force post + # transaction + 'type', # Transaction Type: 0 - purchase, 40 - refund, + # 20 - force post + 'result', # Processing Result: 3 - Approval, + # 4 - Declined/Amount over limit, + # 5 - Invalid/Expired/stolen card, + # 6 - Comm Error + '', # Terminal ID: Terminal ID used to process the transaction + ); + + $end_condition = sub { + my $hash = shift; + $hash->{'type'} eq '0BC'; + }; + + $end_hook = sub { + my( $hash, $total) = @_; + $total = sprintf("%.2f", $total); + my $batch_total = sprintf("%.2f", $hash->{'paybatchnum'} / 100 ); + return "Our total $total does not match bank total $batch_total!" + if $total != $batch_total; + ''; + }; + + $hook = sub { + my $hash = shift; + $hash->{'paid'} = sprintf("%.2f", $hash->{'paid'} / 100 ); + $hash->{'_date'} = timelocal( substr($hash->{'time'}, 4, 2), + substr($hash->{'time'}, 2, 2), + substr($hash->{'time'}, 0, 2), + substr($hash->{'_date'}, 6, 2), + substr($hash->{'_date'}, 4, 2)-1, + substr($hash->{'_date'}, 0, 4)-1900, ); + }; + + $approved_condition = sub { + my $hash = shift; + $hash->{'type'} eq '0' && $hash->{'result'} == 3; + }; + + $declined_condition = sub { + my $hash = shift; + $hash->{'type'} eq '0' && ( $hash->{'result'} == 4 + || $hash->{'result'} == 5 ); + }; + + + }elsif ( $format eq 'csv-chase_canada-E-xactBatch' ) { + + $filetype = "CSV"; + + @fields = ( + '', # Internal(bank) id of the transaction + '', # Transaction Type: 00 - purchase, 01 - preauth, + # 02 - completion, 03 - forcepost, + # 04 - refund, 05 - auth, + # 06 - purchase corr, 07 - refund corr, + # 08 - void 09 - void return + '', # gateway used to process this transaction + 'paid', # Amount: Amount of the transaction. Dollars and cents + # with decimal entered. + 'auth', # Auth#: Authorization number (if approved) + 'payinfo', # Card Number: Card number for the transaction + '', # Expiry Date: Expiry date of the card + '', # Cardholder Name + 'bankcode', # Bank response code (3 alphanumeric) + 'bankmess', # Bank response message + 'etgcode', # ETG response code (2 alphanumeric) + 'etgmess', # ETG response message + '', # Returned customer number for the transaction + 'paybatchnum', # Reference#: paybatch number of the transaction + '', # Reference#: Invoice number of the transaction + 'result', # Processing Result: Approved of Declined + ); + + $end_condition = sub { + ''; + }; + + $hook = sub { + my $hash = shift; + my $cpb = shift; + $hash->{'paid'} = sprintf("%.2f", $hash->{'paid'}); #hmmmm + $hash->{'_date'} = time; # got a better one? + $hash->{'payinfo'} = $cpb->{'payinfo'} + if( substr($hash->{'payinfo'}, -4) eq substr($cpb->{'payinfo'}, -4) ); + }; + + $approved_condition = sub { + my $hash = shift; + $hash->{'etgcode'} eq '00' && $hash->{'result'} eq "Approved"; + }; + + $declined_condition = sub { + my $hash = shift; + $hash->{'etgcode'} ne '00' # internal processing error + || ( $hash->{'result'} eq "Declined" ); + }; + + + }elsif ( $format eq 'PAP' ) { + + $filetype = "Fixed264"; + + @fields = ( + 'recordtype', # We are interested in the 'D' or debit records + 'batchnum', # Record#: batch number we used when sending the file + 'datacenter', # Where in the bowels of the bank the data was processed + 'paid', # Amount: Amount of the transaction. Dollars and cents + # with no decimal entered. + '_date', # Transaction Date: Date the Transaction was processed + 'bank', # Routing information + 'payinfo', # Account number for the transaction + 'paybatchnum', # Reference#: Invoice number of the transaction + ); + + $formatre = '^(.).{19}(.{4})(.{3})(.{10})(.{6})(.{9})(.{12}).{110}(.{19}).{71}$'; + + $end_condition = sub { + my $hash = shift; + $hash->{'recordtype'} eq 'W'; + }; + + $end_hook = sub { + my( $hash, $total) = @_; + $total = sprintf("%.2f", $total); + my $batch_total = $hash->{'datacenter'}.$hash->{'paid'}. + substr($hash->{'_date'},0,1); # YUCK! + $batch_total = sprintf("%.2f", $batch_total / 100 ); + return "Our total $total does not match bank total $batch_total!" + if $total != $batch_total; + ''; + }; + + $hook = sub { + my $hash = shift; + $hash->{'paid'} = sprintf("%.2f", $hash->{'paid'} / 100 ); + my $tmpdate = timelocal( 0,0,1,1,0,substr($hash->{'_date'}, 0, 3)+2000); + $tmpdate += 86400*(substr($hash->{'_date'}, 3, 3)-1) ; + $hash->{'_date'} = $tmpdate; + $hash->{'payinfo'} = $hash->{'payinfo'} . '@' . $hash->{'bank'}; + }; + + $approved_condition = sub { + 1; + }; + + $declined_condition = sub { + 0; + }; + + + } else { + return "Unknown format $format"; + } + + my $csv = new Text::CSV_XS; + + 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 $reself = $self->select_for_update; + + unless ( $reself->status eq 'I' ) { + $dbh->rollback if $oldAutoCommit; + return "batchnum ". $self->batchnum. "no longer in transit"; + }; + + my $error = $self->set_status('R'); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error + } + + my $total = 0; + my $line; + while ( defined($line=<$fh>) ) { + + next if $line =~ /^\s*$/; #skip blank lines + + if ($filetype eq "CSV") { + $csv->parse($line) or do { + $dbh->rollback if $oldAutoCommit; + return "can't parse: ". $csv->error_input(); + }; + @values = $csv->fields(); + }elsif ($filetype eq "Fixed80" || $filetype eq "Fixed264"){ + @values = $line =~ /$formatre/; + unless (@values) { + $dbh->rollback if $oldAutoCommit; + return "can't parse: ". $line; + }; + }else{ + $dbh->rollback if $oldAutoCommit; + return "Unknown file type $filetype"; + } + + my %hash; + foreach my $field ( @fields ) { + my $value = shift @values; + next unless $field; + $hash{$field} = $value; + } + + if ( &{$end_condition}(\%hash) ) { + my $error = &{$end_hook}(\%hash, $total); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + last; + } + + my $cust_pay_batch = + qsearchs('cust_pay_batch', { 'paybatchnum' => $hash{'paybatchnum'}+0 } ); + unless ( $cust_pay_batch ) { + return "unknown paybatchnum $hash{'paybatchnum'}\n"; + } + my $custnum = $cust_pay_batch->custnum, + my $payby = $cust_pay_batch->payby, + + my $new_cust_pay_batch = new FS::cust_pay_batch { $cust_pay_batch->hash }; + + &{$hook}(\%hash, $cust_pay_batch->hashref); + + if ( &{$approved_condition}(\%hash) ) { + + $new_cust_pay_batch->status('Approved'); + + my $cust_pay = new FS::cust_pay ( { + 'custnum' => $custnum, + 'payby' => $payby, + 'paybatch' => $self->batchnum, + map { $_ => $hash{$_} } (qw( paid _date payinfo )), + } ); + $error = $cust_pay->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "error adding payment paybatchnum $hash{'paybatchnum'}: $error\n"; + } + $total += $hash{'paid'}; + + $cust_pay->cust_main->apply_payments; + + } elsif ( &{$declined_condition}(\%hash) ) { + + $new_cust_pay_batch->status('Declined'); + + foreach my $part_bill_event ( due_events ( $new_cust_pay_batch, + 'DCLN', + '', + '') ) { + + # don't run subsequent events if balance<=0 + last if $cust_pay_batch->cust_main->balance <= 0; + + if (my $error = $part_bill_event->do_event($new_cust_pay_batch)) { + # gah, even with transactions. + $dbh->commit if $oldAutoCommit; #well. + return $error; + } + + } + + } + + my $error = $new_cust_pay_batch->replace($cust_pay_batch); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "error updating status of paybatchnum $hash{'paybatchnum'}: $error\n"; + } + + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; + +} + +=back + +=head1 BUGS + +status is somewhat redundant now that download and upload exist + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/payby.pm b/FS/FS/payby.pm new file mode 100644 index 000000000..28afd037f --- /dev/null +++ b/FS/FS/payby.pm @@ -0,0 +1,195 @@ +package FS::payby; + +use strict; +use vars qw(%hash %payby2bop); +use Tie::IxHash; +use Business::CreditCard; + + +=head1 NAME + +FS::payby - Object methods for payment type records + +=head1 SYNOPSIS + + use FS::payby; + + #for now... + + my @payby = FS::payby->payby; + + my $bool = FS::payby->can_payby('cust_main', 'CARD'); + + tie my %payby, 'Tie::IxHash', FS::payby->payby2longname + + my @cust_payby = FS::payby->cust_payby; + + tie my %payby, 'Tie::IxHash', FS::payby->cust_payby2longname + +=head1 DESCRIPTION + +Payment types. + +=head1 METHODS + +=over 4 + +=item + +=cut + +# paybys can be any/all of: +# - a customer payment type (cust_main.payby) +# - a payment or refund type (cust_pay.payby, cust_pay_batch.payby, cust_refund.payby) +# - an event type (part_bill_event.payby) + +tie %hash, 'Tie::IxHash', + 'CARD' => { + tinyname => 'card', + shortname => 'Credit card', + longname => 'Credit card (automatic)', + }, + 'DCRD' => { + tinyname => 'card', + shortname => 'Credit card', + longname => 'Credit card (on-demand)', + cust_pay => 'CARD', #this is a customer type only, payments are CARD... + }, + 'CHEK' => { + tinyname => 'check', + shortname => 'Electronic check', + longname => 'Electronic check (automatic)', + }, + 'DCHK' => { + tinyname => 'check', + shortname => 'Electronic check', + longname => 'Electronic check (on-demand)', + cust_pay => 'CHEK', #this is a customer type only, payments are CHEK... + }, + 'LECB' => { + tinyname => 'phone bill', + shortname => 'Phone bill billing', + longname => 'Phone bill billing', + }, + 'BILL' => { + tinyname => 'billing', + shortname => 'Billing', + longname => 'Billing', + }, + 'PREP' => { + tinyname => 'prepaid card', + shortname => 'Prepaid card', + longname => 'Prepaid card', + cust_main => 'BILL', #this is a payment type only, customers go to BILL... + }, + 'CASH' => { + tinyname => 'cash', + shortname => 'Cash', # initial payment, then billing + longname => 'Cash', + cust_main => 'BILL', #this is a payment type only, customers go to BILL... + }, + 'WEST' => { + tinyname => 'western union', + shortname => 'Western Union', # initial payment, then billing + longname => 'Western Union', + cust_main => 'BILL', #this is a payment type only, customers go to BILL... + }, + 'MCRD' => { #not the same as DCRD + tinyname => 'card', + shortname => 'Manual credit card', # initial payment, then billing + longname => 'Manual credit card', + cust_main => 'BILL', #this is a payment type only, customers go to BILL... + }, + 'COMP' => { + tinyname => 'comp', + shortname => 'Complimentary', + longname => 'Complimentary', + cust_pay => '', # (free) is depricated as a payment type in cust_pay + }, + 'CBAK' => { + tinyname => 'chargeback', + shortname => 'Chargeback', + longname => 'Chargeback', + cust_main => '', # not a customer type + }, + 'DCLN' => { # This is only an event. + tinyname => 'declined', + shortname => 'Batch declined payment', + longname => 'Batch declined payment', + + #its neither of these.. + cust_main => '', + cust_pay => '', + + }, +; + +sub payby { + keys %hash; +} + +sub can_payby { + my( $self, $table, $payby ) = @_; + + #return "Illegal payby" unless $hash{$payby}; + return 0 unless $hash{$payby}; + + $table = 'cust_pay' if $table eq 'cust_pay_batch' || $table eq 'cust_refund'; + return 0 if exists( $hash{$payby}->{$table} ); + + return 1; +} + +sub payby2longname { + my $self = shift; + map { $_ => $hash{$_}->{longname} } $self->payby; +} + +sub shortname { + my( $self, $payby ) = @_; + $hash{$payby}->{shortname}; +} + +sub longname { + my( $self, $payby ) = @_; + $hash{$payby}->{longname}; +} + +%payby2bop = ( + 'CARD' => 'CC', + 'CHEK' => 'ECHECK', +); + +sub payby2bop { + my( $self, $payby ) = @_; + $payby2bop{ $self->payby2payment($payby) }; +} + +sub payby2payment { + my( $self, $payby ) = @_; + $hash{$payby}{'cust_pay'} || $payby; +} + +sub cust_payby { + my $self = shift; + grep { ! exists $hash{$_}->{cust_main} } $self->payby; +} + +sub cust_payby2longname { + my $self = shift; + map { $_ => $hash{$_}->{longname} } $self->cust_payby; +} + +=back + +=head1 BUGS + +This should eventually be an actual database table, and all tables that +currently have a char payby field should have a foreign key into here instead. + +=head1 SEE ALSO + +=cut + +1; + diff --git a/FS/FS/payinfo_Mixin.pm b/FS/FS/payinfo_Mixin.pm new file mode 100644 index 000000000..2d7b4ffe0 --- /dev/null +++ b/FS/FS/payinfo_Mixin.pm @@ -0,0 +1,243 @@ +package FS::payinfo_Mixin; + +use strict; +use Business::CreditCard; +use FS::payby; + +=head1 NAME + +FS::payinfo_Mixin - Mixin class for records in tables that contain payinfo. + +=head1 SYNOPSIS + +package FS::some_table; +use vars qw(@ISA); +@ISA = qw( FS::payinfo_Mixin FS::Record ); + +=head1 DESCRIPTION + +This is a mixin class for records that contain payinfo. + +This class handles the following functions for payinfo... + +Payment Mask (Generation and Storage) +Data Validation (parent checks need to be sure to call this) +Encryption - In the Future (Pull from Record.pm) +Bad Card Stuff - In the Future (Integrate Banned Pay) +Currency - In the Future + +=head1 FIELDS + +=over 4 + +=item payby + +The following payment types (payby) are supported: + +For Customers (cust_main): +'CARD' (credit card - automatic), 'DCRD' (credit card - on-demand), +'CHEK' (electronic check - automatic), 'DCHK' (electronic check - on-demand), +'LECB' (Phone bill billing), 'BILL' (billing), 'COMP' (free), or +'PREPAY' (special billing type: applies a credit and sets billing type to I<BILL> - see L<FS::prepay_credit>) + +For Refunds (cust_refund): +'CARD' (credit cards), 'CHEK' (electronic check/ACH), +'LECB' (Phone bill billing), 'BILL' (billing), 'CASH' (cash), +'WEST' (Western Union), 'MCRD' (Manual credit card), 'CBAK' Chargeback, or 'COMP' (free) + + +For Payments (cust_pay): +'CARD' (credit cards), 'CHEK' (electronic check/ACH), +'LECB' (phone bill billing), 'BILL' (billing), 'PREP' (prepaid card), +'CASH' (cash), 'WEST' (Western Union), or 'MCRD' (Manual credit card) +'COMP' (free) is depricated as a payment type in cust_pay + +=cut + +# was this supposed to do something? + +#sub payby { +# my($self,$payby) = @_; +# if ( defined($payby) ) { +# $self->setfield('payby', $payby); +# } +# return $self->getfield('payby') +#} + +=item payinfo + +Payment information (payinfo) can be one of the following types: + +Card Number, P.O., comp issuer (4-8 lowercase alphanumerics; think username) or prepayment identifier (see L<FS::prepay_credit>) + +=cut + +sub payinfo { + my($self,$payinfo) = @_; + if ( defined($payinfo) ) { + $self->setfield('payinfo', $payinfo); # This is okay since we are the 'setter' + $self->paymask($self->mask_payinfo()); + } else { + $payinfo = $self->getfield('payinfo'); # This is okay since we are the 'getter' + return $payinfo; + } +} + +=item paycvv + +Card Verification Value, "CVV2" (also known as CVC2 or CID), the 3 or 4 digit number on the back (or front, for American Express) of the credit card + +=cut + +sub paycvv { + my($self,$paycvv) = @_; + # This is only allowed in cust_main... Even then it really shouldn't be stored... + if ($self->table eq 'cust_main') { + if ( defined($paycvv) ) { + $self->setfield('paycvv', $paycvv); # This is okay since we are the 'setter' + } else { + $paycvv = $self->getfield('paycvv'); # This is okay since we are the 'getter' + return $paycvv; + } + } else { +# warn "This doesn't work for other tables besides cust_main + ''; + } +} + +=item paymask + +=cut + +sub paymask { + my($self, $paymask) = @_; + + if ( defined($paymask) && $paymask ne '' ) { + # I hate this little bit of magic... I don't expect it to cause a problem, + # but who knows... If the payinfo is passed in masked then ignore it and + # set it based on the payinfo. The only guy that should call this in this + # way is... $self->payinfo + $self->setfield('paymask', $self->mask_payinfo()); + + } else { + + $paymask=$self->getfield('paymask'); + if (!defined($paymask) || $paymask eq '') { + # Generate it if it's blank - Note that we're not going to set it - just + # generate + $paymask = $self->mask_payinfo(); + } + + } + + return $paymask; +} + +=back + +=head1 METHODS + +=over 4 + +=item mask_payinfo [ PAYBY, PAYINFO ] + +This method converts the payment info (credit card, bank account, etc.) into a +masked string. + +Optionally, an arbitrary payby and payinfo can be passed. + +=cut + +sub mask_payinfo { + my $self = shift; + my $payby = scalar(@_) ? shift : $self->payby; + my $payinfo = scalar(@_) ? shift : $self->payinfo; + + # Check to see if it's encrypted... + my $paymask; + if ( $self->is_encrypted($payinfo) ) { + $paymask = 'N/A'; + } else { + # if not, mask it... + if ($payby eq 'CARD' || $payby eq 'DCRD' || $payby eq 'MCRD') { + # Credit Cards (Show first and last four) + $paymask = substr($payinfo,0,6). + 'x'x(length($payinfo)-10). + substr($payinfo,(length($payinfo)-4)); + } elsif ($payby eq 'CHEK' || $payby eq 'DCHK' ) { + # Checks (Show last 2 @ bank) + my( $account, $aba ) = split('@', $payinfo ); + $paymask = 'x'x(length($account)-2). + substr($account,(length($account)-2))."@".$aba; + } else { # Tie up loose ends + $paymask = $payinfo; + } + } + return $paymask; +} + +=cut + +sub _mask_payinfo { + my $self = shift; + +=item payinfo_check + +Checks payby and payinfo. + +For Customers (cust_main): +'CARD' (credit card - automatic), 'DCRD' (credit card - on-demand), +'CHEK' (electronic check - automatic), 'DCHK' (electronic check - on-demand), +'LECB' (Phone bill billing), 'BILL' (billing), 'COMP' (free), or +'PREPAY' (special billing type: applies a credit - see L<FS::prepay_credit> and sets billing type to I<BILL>) + +For Refunds (cust_refund): +'CARD' (credit cards), 'CHEK' (electronic check/ACH), +'LECB' (Phone bill billing), 'BILL' (billing), 'CASH' (cash), +'WEST' (Western Union), 'MCRD' (Manual credit card), 'CBAK' (Chargeback), or 'COMP' (free) + +For Payments (cust_pay): +'CARD' (credit cards), 'CHEK' (electronic check/ACH), +'LECB' (phone bill billing), 'BILL' (billing), 'PREP' (prepaid card), +'CASH' (cash), 'WEST' (Western Union), or 'MCRD' (Manual credit card) +'COMP' (free) is depricated as a payment type in cust_pay + +=cut + +sub payinfo_check { + my $self = shift; + + FS::payby->can_payby($self->table, $self->payby) + or return "Illegal payby: ". $self->payby; + + 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 { + my $error = $self->ut_textn('payinfo'); + return $error if $error; + } +} + +=head1 BUGS + +Have to add the future items... + +=head1 SEE ALSO + +L<FS::payby>, L<FS::Record> + +=cut + +1; + diff --git a/FS/FS/pkg_class.pm b/FS/FS/pkg_class.pm new file mode 100644 index 000000000..bab6e5e56 --- /dev/null +++ b/FS/FS/pkg_class.pm @@ -0,0 +1,113 @@ +package FS::pkg_class; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch ); +use FS::part_pkg; + +@ISA = qw( FS::Record ); + +=head1 NAME + +FS::pkg_class - Object methods for pkg_class records + +=head1 SYNOPSIS + + use FS::pkg_class; + + $record = new FS::pkg_class \%hash; + $record = new FS::pkg_class { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::pkg_class object represents an package class. Every package definition +(see L<FS::part_pkg>) has, optionally, a package class. FS::pkg_class inherits +from FS::Record. The following fields are currently supported: + +=over 4 + +=item classnum - primary key (assigned automatically for new package classes) + +=item classname - Text name of this package class + +=item disabled - Disabled flag, empty or 'Y' + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new package class. To add the package class to the database, see +L<"insert">. + +=cut + +sub table { 'pkg_class'; } + +=item insert + +Adds this package class to the database. If there is an error, returns the +error, otherwise returns false. + +=item delete + +Deletes this package class from the database. Only package classes with no +associated package definitions 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 pkg_class with part_pkg records!" + if qsearch( 'part_pkg', { 'classnum' => $self->classnum } ); + + $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 package class. 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('classnum') + or $self->ut_text('classname') + or $self->SUPER::check; + +} + +=back + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::Record>, L<FS::part_pkg>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/pkg_svc.pm b/FS/FS/pkg_svc.pm index 065ddbe51..9f3a4a1b7 100644 --- a/FS/FS/pkg_svc.pm +++ b/FS/FS/pkg_svc.pm @@ -82,7 +82,9 @@ returns the error, otherwise returns false. =cut sub replace { - my ( $new, $old ) = ( shift, shift ); + my( $new, $old ) = ( shift, shift ); + + $old = $new->replace_old unless defined($old); return "Can't change pkgpart!" if $old->pkgpart != $new->pkgpart; return "Can't change svcpart!" if $old->svcpart != $new->svcpart; diff --git a/FS/FS/port.pm b/FS/FS/port.pm index 253727ba7..c26ca85d4 100644 --- a/FS/FS/port.pm +++ b/FS/FS/port.pm @@ -52,7 +52,7 @@ from FS::Record. The following fields are currently supported: =item new HASHREF -Creates a new port. To add the example to the database, see L<"insert">. +Creates a new port. To add the port 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. @@ -91,7 +91,7 @@ returns the error, otherwise returns false. =item check -Checks all fields to make sure this is a valid example. If there is +Checks all fields to make sure this is a valid port. If there is an error, returns the error, otherwise returns false. Called by the insert and replace methods. diff --git a/FS/FS/prepay_credit.pm b/FS/FS/prepay_credit.pm index 92f2a3032..bf85dfaa6 100644 --- a/FS/FS/prepay_credit.pm +++ b/FS/FS/prepay_credit.pm @@ -61,7 +61,7 @@ fields are currently supported: =item new HASHREF -Creates a new pre-paid credit. To add the example to the database, see +Creates a new pre-paid credit. To add the pre-paid credit to the database, see L<"insert">. Note that this stores the hash reference, not a distinct copy of the hash it @@ -110,6 +110,9 @@ sub check { || $self->ut_alpha('identifier') || $self->ut_money('amount') || $self->ut_numbern('seconds') + || $self->ut_numbern('upbytes') + || $self->ut_numbern('downbytes') + || $self->ut_numbern('totalbytes') || $self->ut_foreign_keyn('agentnum', 'agent', 'agentnum') || $self->SUPER::check ; diff --git a/FS/FS/queue.pm b/FS/FS/queue.pm index f42d99837..5f8bf11f0 100644 --- a/FS/FS/queue.pm +++ b/FS/FS/queue.pm @@ -68,7 +68,7 @@ FS::Record. The following fields are currently supported: =item new HASHREF -Creates a new job. To add the example to the database, see L<"insert">. +Creates a new job. To add the job 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. diff --git a/FS/FS/queue_arg.pm b/FS/FS/queue_arg.pm index 39c71192f..c96ff1236 100644 --- a/FS/FS/queue_arg.pm +++ b/FS/FS/queue_arg.pm @@ -46,7 +46,7 @@ FS::Record. The following fields are currently supported: =item new HASHREF -Creates a new argument. To add the example to the database, see L<"insert">. +Creates a new argument. To add the argument 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. diff --git a/FS/FS/queue_depend.pm b/FS/FS/queue_depend.pm index bc910d8e9..99a22c5c6 100644 --- a/FS/FS/queue_depend.pm +++ b/FS/FS/queue_depend.pm @@ -43,7 +43,7 @@ inherits from FS::Record. The following fields are currently supported: The job specified by B<jobnum> depends on the job specified B<depend_jobnum> - the B<jobnum> job will not be run until the B<depend_jobnum> job has completed -sucessfully (or manually removed). +successfully (or manually removed). =head1 METHODS diff --git a/FS/FS/rate.pm b/FS/FS/rate.pm index a471e2ea4..c50ca044a 100644 --- a/FS/FS/rate.pm +++ b/FS/FS/rate.pm @@ -7,7 +7,7 @@ use FS::rate_detail; @ISA = qw(FS::Record); -$DEBUG = 1; +$DEBUG = 0; =head1 NAME diff --git a/FS/FS/rate_detail.pm b/FS/FS/rate_detail.pm index 7d54355fb..6f023f575 100644 --- a/FS/FS/rate_detail.pm +++ b/FS/FS/rate_detail.pm @@ -56,7 +56,8 @@ inherits from FS::Record. The following fields are currently supported: =item new HASHREF -Creates a new example. To add the example to the database, see L<"insert">. +Creates a new call plan rate. To add the call plan rate 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. @@ -95,7 +96,7 @@ returns the error, otherwise returns false. =item check -Checks all fields to make sure this is a valid example. If there is +Checks all fields to make sure this is a valid call plan rate. If there is an error, returns the error, otherwise returns false. Called by the insert and replace methods. @@ -113,7 +114,11 @@ sub check { || $self->ut_foreign_keyn('orig_regionnum', 'rate_region', 'regionnum' ) || $self->ut_foreign_key('dest_regionnum', 'rate_region', 'regionnum' ) || $self->ut_number('min_included') - || $self->ut_money('min_charge') + + #|| $self->ut_money('min_charge') + #good enough for now... + || $self->ut_float('min_charge') + || $self->ut_number('sec_granularity') ; return $error if $error; @@ -121,6 +126,30 @@ sub check { $self->SUPER::check; } +=item orig_region + +Returns the origination region (see L<FS::rate_region>) associated with this +call plan rate. + +=cut + +sub orig_region { + my $self = shift; + qsearchs('rate_region', { 'regionnum' => $self->orig_regionnum } ); +} + +=item dest_region + +Returns the destination region (see L<FS::rate_region>) associated with this +call plan rate. + +=cut + +sub dest_region { + my $self = shift; + qsearchs('rate_region', { 'regionnum' => $self->dest_regionnum } ); +} + =back =head1 BUGS diff --git a/FS/FS/reason.pm b/FS/FS/reason.pm new file mode 100644 index 000000000..0ce2f80b0 --- /dev/null +++ b/FS/FS/reason.pm @@ -0,0 +1,125 @@ +package FS::reason; + +use strict; +use vars qw( @ISA ); +use FS::reason_type; +use FS::Record qw( qsearch qsearchs ); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::reason - Object methods for reason records + +=head1 SYNOPSIS + + use FS::reason; + + $record = new FS::reason \%hash; + $record = new FS::reason { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::reason object represents a reason message. FS::reason inherits from +FS::Record. The following fields are currently supported: + +=over 4 + +=item reasonnum - primary key + +=item reason_type - index into FS::reason_type + +=item reason - text of the reason + +=item disabled - 'Y' or '' + + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new reason. 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 { 'reason'; } + +=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 reason. 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('reasonnum') + || $self->ut_text('reason') + ; + return $error if $error; + + $self->SUPER::check; +} + +=item reasontype + +Returns the reason_type (see <I>FS::reason_type</I>) associated with this reason. + +=cut + +sub reasontype { + qsearchs( 'reason_type', { 'typenum' => shift->reason_type } ); +} + +=back + +=head1 BUGS + +Here be termintes. Don't use on wooden computers. + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/reason_type.pm b/FS/FS/reason_type.pm new file mode 100644 index 000000000..89278d08a --- /dev/null +++ b/FS/FS/reason_type.pm @@ -0,0 +1,135 @@ +package FS::reason_type; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::reason_type - Object methods for reason_type records + +=head1 SYNOPSIS + + use FS::reason_type; + + $record = new FS::reason_type \%hash; + $record = new FS::reason_type { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::reason_type object represents a grouping of reasons. FS::reason_type +inherits from FS::Record. The following fields are currently supported: + +=over 4 + +=item typenum - primary key + +=item class - currently 'C' or 'S' for cancel or suspend + +=item type - name of the type of reason + + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new reason_type. 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 { 'reason_type'; } + +=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 reason_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; + + my $error = + $self->ut_numbern('typenum') + || $self->ut_enum('class', [ 'C', 'S' ] ) + || $self->ut_text('type') + ; + return $error if $error; + + $self->SUPER::check; +} + +=item reasons + +Returns a list of all reasons associated with this type. + +=cut + +sub reasons { + qsearch( 'reason', { 'reason_type' => shift->typenum } ); +} + +=item enabled_reasons + +Returns a list of enabled reasons associated with this type. + +=cut + +sub enabled_reasons { + qsearch( 'reason', { 'reason_type' => shift->typenum, + 'enabled' => '', + } ); +} + +=back + +=head1 BUGS + +Here be termintes. Don't use on wooden computers. + +=head1 SEE ALSO + +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/reg_code_pkg.pm b/FS/FS/reg_code_pkg.pm index 9b9a87712..837b755e6 100644 --- a/FS/FS/reg_code_pkg.pm +++ b/FS/FS/reg_code_pkg.pm @@ -49,7 +49,8 @@ supported: =item new HASHREF -Creates a new example. To add the example to the database, see L<"insert">. +Creates a new registration code. To add the registration code 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. diff --git a/FS/FS/registrar.pm b/FS/FS/registrar.pm new file mode 100644 index 000000000..cf5dc4907 --- /dev/null +++ b/FS/FS/registrar.pm @@ -0,0 +1,119 @@ +package FS::registrar; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::registrar - Object methods for registrar records + +=head1 SYNOPSIS + + use FS::registrar; + + $record = new FS::registrar \%hash; + $record = new FS::registrar { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::registrar object represents a registrar. FS::registrar inherits from +FS::Record. The following fields are currently supported: + +=over 4 + +=item registrarnum - primary key + +=item registrarname - + + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new registrar. To add the registrar 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 { 'registrar'; } + +=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 registrar. 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('registrarnum') + || $self->ut_text('registrarname') + ; + return $error if $error; + + $self->SUPER::check; +} + +=back + +=head1 BUGS + +=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 index 962e36a07..f60a7d945 100644 --- a/FS/FS/svc_Common.pm +++ b/FS/FS/svc_Common.pm @@ -1,17 +1,20 @@ package FS::svc_Common; use strict; -use vars qw( @ISA $noexport_hack $DEBUG ); -use Carp; +use vars qw( @ISA $noexport_hack $DEBUG $me ); +use Carp qw( cluck carp croak ); #specify cluck have to specify them all.. use FS::Record qw( qsearch qsearchs fields dbh ); use FS::cust_main_Mixin; use FS::cust_svc; use FS::part_svc; use FS::queue; use FS::cust_main; +use FS::inventory_item; +use FS::inventory_class; @ISA = qw( FS::cust_main_Mixin FS::Record ); +$me = '[FS::svc_Common]'; $DEBUG = 0; =head1 NAME @@ -33,6 +36,27 @@ inherit from, i.e. FS::svc_acct. FS::svc_Common inherits from FS::Record. =over 4 +=item search_sql_field FIELD STRING + +Class method which returns an SQL fragment to search for STRING in FIELD. + +=cut + +sub search_sql_field { + my( $class, $field, $string ) = @_; + my $table = $class->table; + my $q_string = dbh->quote($string); + "$table.$field = $q_string"; +} + +#fallback for services that don't provide a search... +sub search_sql { + #my( $class, $string ) = @_; + '1 = 0'; #false +} + +=item new + =cut sub new { @@ -49,7 +73,10 @@ sub new { #$self->{'Hash'} = shift; my $newhash = shift; $self->{'Hash'} = { map { $_ => $newhash->{$_} } qw(svcnum svcpart) }; - $self->setdefault; + + $self->setdefault( $self->_fieldhandlers ) + unless $self->svcnum; + $self->{'Hash'}{$_} = $newhash->{$_} foreach grep { defined($newhash->{$_}) && length($newhash->{$_}) } keys %$newhash; @@ -67,6 +94,9 @@ sub new { $self; } +#empty default +sub _fieldhandlers { {}; } + sub virtual_fields { # This restricts the fields based on part_svc_column and the svcpart of @@ -105,6 +135,19 @@ sub virtual_fields { return (); } +=item label + +svc_Common provides a fallback label subroutine that just returns the svcnum. + +=cut + +sub label { + my $self = shift; + cluck "warning: ". ref($self). " not loaded or missing label method; ". + "using svcnum"; + $self->svcnum; +} + =item check Checks the validity of fields in this record. @@ -149,13 +192,13 @@ jobnum(s) (they will not run until the specific job(s) complete(s)). sub insert { my $self = shift; my %options = @_; - warn "FS::svc_Common::insert called with options ". - join(', ', map { "$_: $options{$_}" } keys %options ). "\n" - if $DEBUG; + warn "[$me] insert called with options ". + join(', ', map { "$_: $options{$_}" } keys %options ). "\n" + if $DEBUG; my @jobnums = (); local $FS::queue::jobnums = \@jobnums; - warn "FS::svc_Common::insert: set \$FS::queue::jobnums to $FS::queue::jobnums" + warn "[$me] insert: set \$FS::queue::jobnums to $FS::queue::jobnums\n" if $DEBUG; my $objects = $options{'child_objects'} || []; my $depend_jobnums = $options{'depend_jobnum'} || []; @@ -202,6 +245,12 @@ sub insert { $self->svcpart($cust_svc->svcpart); } + $error = $self->set_auto_inventory; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + $error = $self->SUPER::insert; if ( $error ) { $dbh->rollback if $oldAutoCommit; @@ -227,7 +276,7 @@ sub insert { #new-style exports! unless ( $noexport_hack ) { - warn "FS::svc_Common::insert: \$FS::queue::jobnums is $FS::queue::jobnums" + warn "[$me] insert: \$FS::queue::jobnums is $FS::queue::jobnums\n" if $DEBUG; foreach my $part_export ( $self->cust_svc->part_svc->part_export ) { @@ -240,11 +289,11 @@ sub insert { } foreach my $depend_jobnum ( @$depend_jobnums ) { - warn "inserting dependancies on supplied job $depend_jobnum\n" + warn "[$me] inserting dependancies on supplied job $depend_jobnum\n" if $DEBUG; foreach my $jobnum ( @jobnums ) { my $queue = qsearchs('queue', { 'jobnum' => $jobnum } ); - warn "inserting dependancy for job $jobnum on $depend_jobnum\n" + warn "[$me] inserting dependancy for job $jobnum on $depend_jobnum\n" if $DEBUG; my $error = $queue->depend_insert($depend_jobnum); if ( $error ) { @@ -285,33 +334,20 @@ sub delete { local $SIG{TSTP} = 'IGNORE'; local $SIG{PIPE} = 'IGNORE'; - my $svcnum = $self->svcnum; - my $oldAutoCommit = $FS::UID::AutoCommit; local $FS::UID::AutoCommit = 0; my $dbh = dbh; - $error = $self->SUPER::delete; - return $error if $error; - - #new-style exports! - unless ( $noexport_hack ) { - foreach my $part_export ( $self->cust_svc->part_svc->part_export ) { - my $error = $part_export->export_delete($self); - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "exporting to ". $part_export->exporttype. - " (transaction rolled back): $error"; - } - } + $error = $self->SUPER::delete + || $self->export('delete') + || $self->return_inventory + || $self->cust_svc->delete + ; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; } - return $error if $error; - - my $cust_svc = $self->cust_svc; - $error = $cust_svc->delete; - return $error if $error; - $dbh->commit or die $dbh->errstr if $oldAutoCommit; ''; @@ -338,7 +374,16 @@ sub replace { local $FS::UID::AutoCommit = 0; my $dbh = dbh; - my $error = $new->SUPER::replace($old); + # We absolutely have to have an old vs. new record to make this work. + $old = $new->replace_old unless defined($old); + + my $error = $new->set_auto_inventory; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + $error = $new->SUPER::replace($old); if ($error) { $dbh->rollback if $oldAutoCommit; return $error; @@ -409,7 +454,7 @@ to test the return). Usually called by the check method. sub setfixed { my $self = shift; - $self->setx('F'); + $self->setx('F', @_); } =item setdefault @@ -422,20 +467,66 @@ the FS::part_svc object (use ref() to test the return). sub setdefault { my $self = shift; - $self->setx('D'); + $self->setx('D', @_ ); +} + +=item set_default_and_fixed + +=cut + +sub set_default_and_fixed { + my $self = shift; + $self->setx( [ 'D', 'F' ], @_ ); } +=item setx FLAG | FLAG_ARRAYREF , [ CALLBACK_HASHREF ] + +Sets fields according to the passed in flag or arrayref of flags. + +Optionally, a hashref of field names and callback coderefs can be passed. +If a coderef exists for a given field name, instead of setting the field, +the coderef is called with the column value (part_svc_column.columnvalue) +as the single parameter. + +=cut + sub setx { my $self = shift; my $x = shift; + my @x = ref($x) ? @$x : ($x); + my $coderef = scalar(@_) ? shift : $self->_fieldhandlers; - my $error; - - $error = + my $error = $self->ut_numbern('svcnum') ; return $error if $error; + my $part_svc = $self->part_svc; + return "Unkonwn svcpart" unless $part_svc; + + #set default/fixed/whatever fields from part_svc + + foreach my $part_svc_column ( + grep { my $f = $_->columnflag; grep { $f eq $_ } @x } #columnflag in @x + $part_svc->all_part_svc_column + ) { + + my $columnname = $part_svc_column->columnname; + my $columnvalue = $part_svc_column->columnvalue; + + $columnvalue = &{ $coderef->{$columnname} }( $self, $columnvalue ) + if exists( $coderef->{$columnname} ); + $self->setfield( $columnname, $columnvalue ); + + } + + $part_svc; + +} + +sub part_svc { + my $self = shift; + #get part_svc my $svcpart; if ( $self->get('svcpart') ) { @@ -445,41 +536,89 @@ sub setx { return "Unknown svcnum" unless $cust_svc; $svcpart = $cust_svc->svcpart; } - my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $svcpart } ); + + qsearchs( 'part_svc', { 'svcpart' => $svcpart } ); + +} + +=item set_auto_inventory + +Sets any fields which auto-populate from inventory (see L<FS::part_svc>). +If there is an error, returns the error, otherwise returns false. + +=cut + +sub set_auto_inventory { + my $self = shift; + + my $error = + $self->ut_numbern('svcnum') + ; + return $error if $error; + + my $part_svc = $self->part_svc; return "Unkonwn svcpart" unless $part_svc; + 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; + #set default/fixed/whatever fields from part_svc my $table = $self->table; foreach my $field ( grep { $_ ne 'svcnum' } $self->fields ) { my $part_svc_column = $part_svc->part_svc_column($field); - if ( $part_svc_column->columnflag eq $x ) { - $self->setfield( $field, $part_svc_column->columnvalue ); - } - } + if ( $part_svc_column->columnflag eq 'A' && $self->$field() eq '' ) { + + my $classnum = $part_svc_column->columnvalue; + my $inventory_item = qsearchs({ + 'table' => 'inventory_item', + 'hashref' => { 'classnum' => $classnum, + 'svcnum' => '', + }, + 'extra_sql' => 'LIMIT 1 FOR UPDATE', + }); + + unless ( $inventory_item ) { + $dbh->rollback if $oldAutoCommit; + my $inventory_class = + qsearchs('inventory_class', { 'classnum' => $classnum } ); + return "Can't find inventory_class.classnum $classnum" + unless $inventory_class; + return "Out of ". $inventory_class->classname. "s\n"; #Lingua:: BS + #for pluralizing + } - $part_svc; + $inventory_item->svcnum( $self->svcnum ); + my $ierror = $inventory_item->replace(); + if ( $ierror ) { + $dbh->rollback if $oldAutoCommit; + return "Error provisioning inventory: $ierror"; + + } -} + $self->setfield( $field, $inventory_item->item ); -=item cust_svc + } + } -Returns the cust_svc record associated with this svc_ record, as a FS::cust_svc -object (see L<FS::cust_svc>). + $dbh->commit or die $dbh->errstr if $oldAutoCommit; -=cut + ''; -sub cust_svc { - my $self = shift; - qsearchs('cust_svc', { 'svcnum' => $self->svcnum } ); } -=item suspend - -Runs export_suspend callbacks. +=item return_inventory =cut -sub suspend { +sub return_inventory { my $self = shift; local $SIG{HUP} = 'IGNORE'; @@ -493,21 +632,56 @@ sub suspend { local $FS::UID::AutoCommit = 0; my $dbh = dbh; - #new-style exports! - unless ( $noexport_hack ) { - foreach my $part_export ( $self->cust_svc->part_svc->part_export ) { - my $error = $part_export->export_suspend($self); - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "error exporting to ". $part_export->exporttype. - " (transaction rolled back): $error"; - } + foreach my $inventory_item ( $self->inventory_item ) { + $inventory_item->svcnum(''); + my $error = $inventory_item->replace(); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Error returning inventory: $error"; } } $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; +} + +=item inventory_item + +Returns the inventory items associated with this svc_ record, as +FS::inventory_item objects (see L<FS::inventory_item>. + +=cut +sub inventory_item { + my $self = shift; + qsearch({ + 'table' => 'inventory_item', + 'hashref' => { 'svcnum' => $self->svcnum, }, + }); +} + +=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 + +Runs export_suspend callbacks. + +=cut + +sub suspend { + my $self = shift; + $self->export('suspend'); } =item unsuspend @@ -518,6 +692,19 @@ Runs export_unsuspend callbacks. sub unsuspend { my $self = shift; + $self->export('unsuspend'); +} + +=item export HOOK [ EXPORT_ARGS ] + +Runs the provided export hook (i.e. "suspend", "unsuspend") for this service. + +=cut + +sub export { + my( $self, $method ) = ( shift, shift ); + + $method = "export_$method" unless $method =~ /^export_/; local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; @@ -533,10 +720,11 @@ sub unsuspend { #new-style exports! unless ( $noexport_hack ) { foreach my $part_export ( $self->cust_svc->part_svc->part_export ) { - my $error = $part_export->export_unsuspend($self); + next unless $part_export->can($method); + my $error = $part_export->$method($self, @_); if ( $error ) { $dbh->rollback if $oldAutoCommit; - return "error exporting to ". $part_export->exporttype. + return "error exporting $method event to ". $part_export->exporttype. " (transaction rolled back): $error"; } } @@ -549,9 +737,13 @@ sub unsuspend { =item cancel -Stub - returns false (no error) so derived classes don't need to define these +Stub - returns false (no error) so derived classes don't need to define this methods. Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>). +This method is called *before* the deletion step which actually deletes the +services. This method should therefore only be used for "pre-deletion" +cancellation steps, if necessary. + =cut sub cancel { ''; } @@ -586,6 +778,8 @@ sub clone_kludge_unsuspend { The setfixed method return value. +B<export> method isn't used by insert and replace methods yet. + =head1 SEE ALSO L<FS::Record>, L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, schema.html diff --git a/FS/FS/svc_External_Common.pm b/FS/FS/svc_External_Common.pm new file mode 100644 index 000000000..a5805aafd --- /dev/null +++ b/FS/FS/svc_External_Common.pm @@ -0,0 +1,199 @@ +package FS::svc_External_Common; + +use strict; +use vars qw(@ISA); +use FS::svc_Common; + +@ISA = qw( FS::svc_Common ); + +=head1 NAME + +FS::svc_external - Object methods for svc_external records + +=head1 SYNOPSIS + + use FS::svc_external; + + $record = new FS::svc_external \%hash; + $record = new FS::svc_external { '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 + +FS::svc_External_Common is intended as a base class for table-specific classes +to inherit from. FS::svc_External_Common is used for services which connect +to externally tracked services via "id" and "table" fields. + +FS::svc_External_Common inherits from FS::svc_Common. + +The following fields are currently supported: + +=over 4 + +=item svcnum - primary key + +=item id - unique number of external record + +=item title - for invoice line items + +=back + +=head1 METHODS + +=over 4 + +=item search_sql + +Provides a default search_sql method which returns an SQL fragment to search +the B<title> field. + +=cut + +sub search_sql { + my($class, $string) = @_; + $class->search_sql_field('title', $string); +} + +=item new HASHREF + +Creates a new external service. To add the external service 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 + +=item label + +Returns a string identifying this external service in the form "id:title" + +=cut + +sub label { + my $self = shift; + $self->id. ':'. $self->title; +} + +=item insert [ , OPTION => VALUE ... ] + +Adds this external service 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. + +Currently available options are: I<depend_jobnum> + +If I<depend_jobnum> is set (to a scalar jobnum or an array reference of +jobnums), all provisioning jobs will have a dependancy on the supplied +jobnum(s) (they will not run until the specific job(s) complete(s)). + +=cut + +#sub insert { +# my $self = shift; +# my $error; +# +# $error = $self->SUPER::insert(@_); +# return $error if $error; +# +# ''; +#} + +=item delete + +Delete this record from the database. + +=cut + +#sub delete { +# my $self = shift; +# my $error; +# +# $error = $self->SUPER::delete; +# return $error if $error; +# +# ''; +#} + + +=item replace OLD_RECORD + +Replaces the OLD_RECORD with this one in the database. If there is an error, +returns the error, otherwise returns false. + +=cut + +#sub replace { +# my ( $new, $old ) = ( shift, shift ); +# my $error; +# +# $error = $new->SUPER::replace($old); +# return $error if $error; +# +# ''; +#} + +=item suspend + +Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>). + +=item unsuspend + +Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>). + +=item cancel + +Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>). + +=item check + +Checks all fields to make sure this is a valid external service. 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 $x = $self->setfixed; + return $x unless ref($x); + my $part_svc = $x; + + my $error = + $self->ut_numbern('svcnum') + || $self->ut_numbern('id') + || $self->ut_textn('title') + ; + + $self->SUPER::check; +} + +=back + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::svc_Common>, L<FS::Record>, L<FS::cust_svc>, L<FS::part_svc>, +L<FS::cust_pkg>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/svc_Parent_Mixin.pm b/FS/FS/svc_Parent_Mixin.pm new file mode 100644 index 000000000..4501bafc8 --- /dev/null +++ b/FS/FS/svc_Parent_Mixin.pm @@ -0,0 +1,103 @@ +package FS::svc_Parent_Mixin; + +use strict; +use NEXT; +use FS::Record qw(qsearch qsearchs); +use FS::cust_svc; + +=head1 NAME + +FS::svc_Parent_Mixin - Mixin class for svc_ classes with a parent_svcnum field + +=head1 SYNOPSIS + +package FS::svc_table; +use vars qw(@ISA); +@ISA = qw( FS::svc_Parent_Mixin FS::svc_Common ); + +=head1 DESCRIPTION + +This is a mixin class for svc_ classes that contain a parent_svcnum field. + +=cut + +=head1 METHODS + +=over 4 + +=item parent_cust_svc + +Returns the parent FS::cust_svc object. + +=cut + +sub parent_cust_svc { + my $self = shift; + qsearchs('cust_svc', { 'svcnum' => $self->parent_svcnum } ); +} + +=item parent_svc_x + +Returns the corresponding parent FS::svc_ object. + +=cut + +sub parent_svc_x { + my $self = shift; + $self->parent_cust_svc->svc_x; +} + +=item children_cust_svc + +Returns a list of any child FS::cust_svc objects. + +Note: This is not recursive; it only returns direct children. + +=cut + +sub children_cust_svc { + my $self = shift; + qsearch('cust_svc', { 'parent_svcnum' => $self->svcnum } ); +} + +=item children_svc_x + +Returns the corresponding list of child FS::svc_ objects. + +=cut + +sub children_svc_x { + my $self = shift; + map { $_->svc_x } $self->children_cust_svc; +} + +=item check + +This class provides a check subroutine which takes care of checking the +parent_svcnum field. The svc_ class which uses it will call SUPER::check at +the end of its own checks, and this class will call NEXT::check to pass +the check "up the chain" (see L<NEXT>). + +=cut + +sub check { + my $self = shift; + + $self->ut_foreign_keyn('parent_svcnum', 'cust_svc', 'svcnum') + || $self->NEXT::check; + +} + +=back + +=head1 BUGS + +Do we need a recursive child finder for multi-layered children? + +=head1 SEE ALSO + +L<FS::svc_Common>, L<FS::Record> + +=cut + +1; diff --git a/FS/FS/svc_acct.pm b/FS/FS/svc_acct.pm index c1851d3ce..0a7d6be6d 100644 --- a/FS/FS/svc_acct.pm +++ b/FS/FS/svc_acct.pm @@ -8,7 +8,10 @@ use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles $username_noperiod $username_nounderscore $username_nodash $username_uppercase $username_percent $password_noampersand $password_noexclamation - $welcome_template $welcome_from $welcome_subject $welcome_mimetype + $welcome_template $welcome_from + $welcome_subject $welcome_subject_template $welcome_mimetype + $warning_template $warning_from $warning_subject $warning_mimetype + $warning_cc $smtpmachine $radius_password $radius_ip $dirhash @@ -17,9 +20,11 @@ use Carp; use Fcntl qw(:flock); use Date::Format; use Crypt::PasswdMD5 1.2; +use Data::Dumper; use FS::UID qw( datasrc ); use FS::Conf; use FS::Record qw( qsearch qsearchs fields dbh dbdef ); +use FS::Msgcat qw(gettext); use FS::svc_Common; use FS::cust_svc; use FS::part_svc; @@ -31,9 +36,9 @@ use FS::queue; use FS::radius_usergroup; use FS::export_svc; use FS::part_export; -use FS::Msgcat qw(gettext); use FS::svc_forward; use FS::svc_www; +use FS::cdr; @ISA = qw( FS::svc_Common ); @@ -67,6 +72,10 @@ $FS::UID::callback{'FS::svc_acct'} = sub { ) or warn "can't create welcome email template: $Text::Template::ERROR"; $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum' $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome'; + $welcome_subject_template = new Text::Template ( + TYPE => 'STRING', + SOURCE => $welcome_subject, + ) or warn "can't create welcome email subject template: $Text::Template::ERROR"; $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain'; } else { $welcome_template = ''; @@ -74,6 +83,22 @@ $FS::UID::callback{'FS::svc_acct'} = sub { $welcome_subject = ''; $welcome_mimetype = ''; } + if ( $conf->exists('warning_email') ) { + $warning_template = new Text::Template ( + TYPE => 'ARRAY', + SOURCE => [ map "$_\n", $conf->config('warning_email') ] + ) or warn "can't create warning email template: $Text::Template::ERROR"; + $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum' + $warning_subject = $conf->config('warning_email-subject') || 'Warning'; + $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain'; + $warning_cc = $conf->config('warning_email-cc'); + } else { + $warning_template = ''; + $warning_from = ''; + $warning_subject = ''; + $warning_mimetype = ''; + $warning_cc = ''; + } $smtpmachine = $conf->config('smtpmachine'); $radius_password = $conf->config('radius-password') || 'Password'; $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address'; @@ -166,6 +191,12 @@ FS::svc_Common. The following fields are currently supported: =item seconds - +=item upbytes - + +=item downbytes - + +=item totalbytes - + =item domsvc - svcnum from svc_domain =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply) @@ -184,8 +215,148 @@ Creates a new account. To add the account to the database, see L<"insert">. =cut +sub table_info { + { + 'name' => 'Account', + 'longname_plural' => 'Access accounts and mailboxes', + 'sorts' => [ 'username', 'uid', ], + 'display_weight' => 10, + 'cancel_weight' => 50, + 'fields' => { + 'dir' => 'Home directory', + 'uid' => { + label => 'UID', + def_label => 'UID (set to fixed and blank for no UIDs)', + type => 'text', + }, + 'slipip' => 'IP address', + # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!, + 'popnum' => { + label => 'Access number', + type => 'select', + select_table => 'svc_acct_pop', + select_key => 'popnum', + select_label => 'city', + disable_select => 1, + }, + 'username' => { + label => 'Username', + type => 'text', + disable_default => 1, + disable_fixed => 1, + disable_select => 1, + }, + 'quota' => { + label => 'Quota', + type => 'text', + disable_inventory => 1, + disable_select => 1, + }, + '_password' => 'Password', + 'gid' => { + label => 'GID', + def_label => 'GID (when blank, defaults to UID)', + type => 'text', + }, + 'shell' => { + #desc =>'Shell (all service definitions should have a default or fixed shell that is present in the <b>shells</b> configuration file, set to blank for no shell tracking)', + label => 'Shell', + def_label=> 'Shell (set to blank for no shell tracking)', + type =>'select', + select_list => [ $conf->config('shells') ], + disable_inventory => 1, + disable_select => 1, + }, + 'finger' => 'Real name (GECOS)', + 'domsvc' => { + label => 'Domain', + #def_label => 'svcnum from svc_domain', + type => 'select', + select_table => 'svc_domain', + select_key => 'svcnum', + select_label => 'domain', + disable_inventory => 1, + + }, + 'usergroup' => { + label => 'RADIUS groups', + type => 'radius_usergroup_selector', + disable_inventory => 1, + disable_select => 1, + }, + 'seconds' => { label => 'Seconds', + type => 'text', + disable_inventory => 1, + disable_select => 1, + }, + }, + }; +} + sub table { 'svc_acct'; } +sub _fieldhandlers { + { + #false laziness with edit/svc_acct.cgi + 'usergroup' => sub { + my( $self, $groups ) = @_; + if ( ref($groups) eq 'ARRAY' ) { + $groups; + } elsif ( length($groups) ) { + [ split(/\s*,\s*/, $groups) ]; + } else { + []; + } + }, + }; +} + +=item search_sql STRING + +Class method which returns an SQL fragment to search for the given string. + +=cut + +sub search_sql { + my( $class, $string ) = @_; + if ( $string =~ /^([^@]+)@([^@]+)$/ ) { + my( $username, $domain ) = ( $1, $2 ); + my $q_username = dbh->quote($username); + my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } ); + if ( @svc_domain ) { + "svc_acct.username = $q_username AND ( ". + join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ). + " )"; + } else { + '1 = 0'; #false + } + } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) { + ' ( '. + $class->search_sql_field('slipip', $string ). + ' OR '. + $class->search_sql_field('username', $string ). + ' ) '; + } else { + $class->search_sql_field('username', $string); + } +} + +=item label [ END_TIMESTAMP [ START_TIMESTAMP ] ] + +Returns the "username@domain" string for this account. + +END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with +history records. + +=cut + +sub label { + my $self = shift; + $self->email(@_); +} + +=cut + =item insert [ , OPTION => VALUE ... ] Adds this account to the database. If there is an error, returns the error, @@ -220,7 +391,11 @@ jobnum(s) (they will not run until the specific job(s) complete(s)). sub insert { my $self = shift; my %options = @_; - my $error; + + if ( $DEBUG ) { + warn "[$me] insert called on $self: ". Dumper($self). + "\nwith options: ". Dumper(%options); + } local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; @@ -233,7 +408,7 @@ sub insert { local $FS::UID::AutoCommit = 0; my $dbh = dbh; - $error = $self->check; + my $error = $self->check; return $error if $error; if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) { @@ -290,7 +465,10 @@ sub insert { if ( $cust_pkg ) { my $cust_main = $cust_pkg->cust_main; - if ( $conf->exists('emailinvoiceauto') ) { + if ( $conf->exists('emailinvoiceautoalways') + || $conf->exists('emailinvoiceauto') + && ! $cust_main->invoicing_list_emailonly + ) { my @invoicing_list = $cust_main->invoicing_list; push @invoicing_list, $self->email; $cust_main->invoicing_list(\@invoicing_list); @@ -301,6 +479,15 @@ sub insert { if ( $welcome_template && $cust_pkg ) { my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list ); if ( $to ) { + + my %hash = ( + 'custnum' => $self->custnum, + 'username' => $self->username, + 'password' => $self->_password, + 'first' => $cust_main->first, + 'last' => $cust_main->getfield('last'), + 'pkg' => $cust_pkg->part_pkg->pkg, + ); my $wqueue = new FS::queue { 'svcnum' => $self->svcnum, 'job' => 'FS::svc_acct::send_email' @@ -308,16 +495,9 @@ sub insert { my $error = $wqueue->insert( 'to' => $to, 'from' => $welcome_from, - 'subject' => $welcome_subject, + 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ), 'mimetype' => $welcome_mimetype, - 'body' => $welcome_template->fill_in( HASH => { - 'custnum' => $self->custnum, - 'username' => $self->username, - 'password' => $self->_password, - 'first' => $cust_main->first, - 'last' => $cust_main->getfield('last'), - 'pkg' => $cust_pkg->part_pkg->pkg, - } ), + 'body' => $welcome_template->fill_in( HASH => \%hash, ), ); if ( $error ) { $dbh->rollback if $oldAutoCommit; @@ -462,6 +642,11 @@ sub replace { my $error; warn "$me replacing $old with $new\n" if $DEBUG; + # We absolutely have to have an old vs. new record to make this work. + if (!defined($old)) { + $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } ); + } + return "can't modify system account" if $old->_check_system; { @@ -681,7 +866,7 @@ sub check { my($recref) = $self->hashref; - my $x = $self->setfixed; + my $x = $self->setfixed( $self->_fieldhandlers ); return $x unless ref($x); my $part_svc = $x; @@ -694,6 +879,10 @@ sub check { #|| $self->ut_number('domsvc') || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' ) || $self->ut_textn('sec_phrase') + || $self->ut_snumbern('seconds') + || $self->ut_snumbern('upbytes') + || $self->ut_snumbern('downbytes') + || $self->ut_snumbern('totalbytes') ; return $error if $error; @@ -843,7 +1032,7 @@ sub check { unless ( $recref->{_password} ); #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) { - if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) { + 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 @@ -852,7 +1041,7 @@ sub check { #$recref->{password} = $1. # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))] #; - } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) { + } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) { $recref->{_password} = $1.$3; } elsif ( $recref->{_password} eq '*' ) { $recref->{_password} = '*'; @@ -901,6 +1090,9 @@ per export and with identical I<svcpart> values. sub _check_duplicate { my $self = shift; + my $global_unique = $conf->config('global_unique-username') || 'none'; + return '' if $global_unique eq 'disabled'; + #this is Pg-specific. what to do for mysql etc? # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ ) warn "$me locking svc_acct table for duplicate search" if $DEBUG; @@ -913,8 +1105,6 @@ sub _check_duplicate { return 'unknown svcpart '. $self->svcpart; } - my $global_unique = $conf->config('global_unique-username') || 'none'; - my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum } qsearch( 'svc_acct', { 'username' => $self->username } ); return gettext('username_in_use') @@ -1077,7 +1267,10 @@ sub radius_check { my $password = $self->_password; my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; $check{$pw_attrib} = $password; - my $cust_pkg = $self->cust_svc->cust_pkg; + my $cust_svc = $self->cust_svc; + die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n" + unless $cust_svc; + my $cust_pkg = $cust_svc->cust_pkg; if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) { $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html } @@ -1121,10 +1314,13 @@ sub forget_snapshot { } -=item domain +=item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ] Returns the domain associated with this account. +END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with +history records. + =cut sub domain { @@ -1142,6 +1338,8 @@ L<FS::svc_domain>). =cut +# FS::h_svc_acct has a history-aware svc_domain override + sub svc_domain { my $self = shift; $self->{'_domsvc'} @@ -1157,10 +1355,13 @@ Returns the FS::cust_svc record for this account (see L<FS::cust_svc>). #inherited from svc_Common -=item email +=item email [ END_TIMESTAMP [ START_TIMESTAMP ] ] Returns an email address associated with the account. +END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with +history records. + =cut sub email { @@ -1184,6 +1385,72 @@ sub acct_snarf { qsearch('acct_snarf', { 'svcnum' => $self->svcnum } ); } +=item decrement_upbytes OCTETS + +Decrements the I<upbytes> field of this record by the given amount. If there +is an error, returns the error, otherwise returns false. + +=cut + +sub decrement_upbytes { + shift->_op_usage('-', 'upbytes', @_); +} + +=item increment_upbytes OCTETS + +Increments the I<upbytes> field of this record by the given amount. If there +is an error, returns the error, otherwise returns false. + +=cut + +sub increment_upbytes { + shift->_op_usage('+', 'upbytes', @_); +} + +=item decrement_downbytes OCTETS + +Decrements the I<downbytes> field of this record by the given amount. If there +is an error, returns the error, otherwise returns false. + +=cut + +sub decrement_downbytes { + shift->_op_usage('-', 'downbytes', @_); +} + +=item increment_downbytes OCTETS + +Increments the I<downbytes> field of this record by the given amount. If there +is an error, returns the error, otherwise returns false. + +=cut + +sub increment_downbytes { + shift->_op_usage('+', 'downbytes', @_); +} + +=item decrement_totalbytes OCTETS + +Decrements the I<totalbytes> field of this record by the given amount. If there +is an error, returns the error, otherwise returns false. + +=cut + +sub decrement_totalbytes { + shift->_op_usage('-', 'totalbytes', @_); +} + +=item increment_totalbytes OCTETS + +Increments the I<totalbytes> field of this record by the given amount. If there +is an error, returns the error, otherwise returns false. + +=cut + +sub increment_totalbytes { + shift->_op_usage('+', 'totalbytes', @_); +} + =item decrement_seconds SECONDS Decrements the I<seconds> field of this record by the given amount. If there @@ -1192,7 +1459,7 @@ is an error, returns the error, otherwise returns false. =cut sub decrement_seconds { - shift->_op_seconds('-', @_); + shift->_op_usage('-', 'seconds', @_); } =item increment_seconds SECONDS @@ -1203,7 +1470,7 @@ is an error, returns the error, otherwise returns false. =cut sub increment_seconds { - shift->_op_seconds('+', @_); + shift->_op_usage('+', 'seconds', @_); } @@ -1212,20 +1479,32 @@ my %op2action = ( '+' => 'unsuspend', ); my %op2condition = ( - '-' => sub { my($self, $seconds) = @_; - $self->seconds - $seconds <= 0; + '-' => sub { my($self, $column, $amount) = @_; + $self->$column - $amount <= 0; + }, + '+' => sub { my($self, $column, $amount) = @_; + $self->$column + $amount > 0; + }, +); +my %op2warncondition = ( + '-' => sub { my($self, $column, $amount) = @_; + my $threshold = $column . '_threshold'; + $self->$column - $amount <= $self->$threshold + 0; }, - '+' => sub { my($self, $seconds) = @_; - $self->seconds + $seconds > 0; + '+' => sub { my($self, $column, $amount) = @_; + $self->$column + $amount > 0; }, ); -sub _op_seconds { - my( $self, $op, $seconds ) = @_; - warn "$me _op_seconds called for svcnum ". $self->svcnum. - ' ('. $self->email. "): $op $seconds\n" +sub _op_usage { + my( $self, $op, $column, $amount ) = @_; + + warn "$me _op_usage called for $column on svcnum ". $self->svcnum. + ' ('. $self->email. "): $op $amount\n" if $DEBUG; + return '' unless $amount; + local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; local $SIG{QUIT} = 'IGNORE'; @@ -1237,24 +1516,46 @@ sub _op_seconds { local $FS::UID::AutoCommit = 0; my $dbh = dbh; - my $sql = "UPDATE svc_acct SET seconds = ". - " CASE WHEN seconds IS NULL THEN 0 ELSE seconds END ". #$seconds||0 + my $sql = "UPDATE svc_acct SET $column = ". + " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0 " $op ? WHERE svcnum = ?"; warn "$me $sql\n" if $DEBUG; my $sth = $dbh->prepare( $sql ) or die "Error preparing $sql: ". $dbh->errstr; - my $rv = $sth->execute($seconds, $self->svcnum); + my $rv = $sth->execute($amount, $self->svcnum); die "Error executing $sql: ". $sth->errstr unless defined($rv); - die "Can't update seconds for svcnum". $self->svcnum + die "Can't update $column for svcnum". $self->svcnum if $rv == 0; my $action = $op2action{$op}; + if ( &{$op2condition{$op}}($self, $column, $amount) ) { + foreach my $part_export ( $self->cust_svc->part_svc->part_export ) { + if ($part_export->option('overlimit_groups')) { + my ($new,$old); + my $other = new FS::svc_acct $self->hashref; + my $groups = &{ $self->_fieldhandlers->{'usergroup'} } + ($self, $part_export->option('overlimit_groups')); + $other->usergroup( $groups ); + if ($action eq 'suspend'){ + $new = $other; $old = $self; + }else{ + $new = $self; $old = $other; + } + my $error = $part_export->export_replace($new, $old); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Error replacing radius groups in export, ${op}: $error"; + } + } + } + } + if ( $conf->exists("svc_acct-usage_$action") - && &{$op2condition{$op}}($self, $seconds) ) { + && &{$op2condition{$op}}($self, $column, $amount) ) { #my $error = $self->$action(); my $error = $self->cust_svc->cust_pkg->$action(); if ( $error ) { @@ -1263,13 +1564,134 @@ sub _op_seconds { } } - warn "$me update sucessful; committing\n" + if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) { + my $wqueue = new FS::queue { + 'svcnum' => $self->svcnum, + 'job' => 'FS::svc_acct::reached_threshold', + }; + + my $to = ''; + if ($op eq '-'){ + $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount); + } + + # x_threshold race + my $error = $wqueue->insert( + 'svcnum' => $self->svcnum, + 'op' => $op, + 'column' => $column, + 'to' => $to, + ); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Error queuing threshold activity: $error"; + } + } + + warn "$me update successful; committing\n" if $DEBUG; $dbh->commit or die $dbh->errstr if $oldAutoCommit; ''; } +sub set_usage { + my( $self, $valueref ) = @_; + + warn "$me set_usage called for svcnum ". $self->svcnum. + ' ('. $self->email. "): ". + join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n" + if $DEBUG; + + local $SIG{HUP} = 'IGNORE'; + local $SIG{INT} = 'IGNORE'; + local $SIG{QUIT} = 'IGNORE'; + local $SIG{TERM} = 'IGNORE'; + local $SIG{TSTP} = 'IGNORE'; + local $SIG{PIPE} = 'IGNORE'; + + local $FS::svc_Common::noexport_hack = 1; + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + my $reset = 0; + foreach my $field (keys %$valueref){ + $reset = 1 if $valueref->{$field}; + $self->setfield($field, $valueref->{$field}); + $self->setfield( $field.'_threshold', + int($self->getfield($field) + * ( $conf->exists('svc_acct-usage_threshold') + ? 1 - $conf->config('svc_acct-usage_threshold')/100 + : 0.20 + ) + ) + ); + } + my $error = $self->replace; + die $error if $error; + + if ( $conf->exists("svc_acct-usage_unsuspend") && $reset ) { + my $error = $self->cust_svc->cust_pkg->unsuspend; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Error unsuspending: $error"; + } + } + + warn "$me update successful; committing\n" + if $DEBUG; + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; + +} + + +=item recharge HASHREF + + Increments usage columns by the amount specified in HASHREF as + column=>amount pairs. + +=cut + +sub recharge { + my ($self, $vhash) = @_; + + if ( $DEBUG ) { + warn "[$me] recharge called on $self: ". Dumper($self). + "\nwith vhash: ". Dumper($vhash); + } + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + my $error = ''; + + foreach my $column (keys %$vhash){ + $error ||= $self->_op_usage('+', $column, $vhash->{$column}); + } + + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + }else{ + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + } + return $error; +} + +=item is_rechargeable + +Returns true if this svc_account can be "recharged" and false otherwise. + +=cut + +sub is_rechargable { + my $self = shift; + $self->seconds ne '' + || $self->upbytes ne '' + || $self->downbytes ne '' + || $self->totalbytes ne ''; +} =item seconds_since TIMESTAMP @@ -1341,6 +1763,67 @@ sub get_session_history { $self->cust_svc->get_session_history(@_); } +=item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ] + +=cut + +sub get_cdrs { + my($self, $start, $end, %opt ) = @_; + + my $did = $self->username; #yup + + my $prefix = $opt{'default_prefix'}; #convergent.au '+61' + + my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : ''; + + #SELECT $for_update * FROM cdr + # WHERE calldate >= $start #need a conversion + # AND calldate < $end #ditto + # AND ( charged_party = "$did" + # OR charged_party = "$prefix$did" #if length($prefix); + # OR ( ( charged_party IS NULL OR charged_party = '' ) + # AND + # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix) + # ) + # ) + # AND ( freesidestatus IS NULL OR freesidestatus = '' ) + + my $charged_or_src; + if ( length($prefix) ) { + $charged_or_src = + " AND ( charged_party = '$did' + OR charged_party = '$prefix$did' + OR ( ( charged_party IS NULL OR charged_party = '' ) + AND + ( src = '$did' OR src = '$prefix$did' ) + ) + ) + "; + } else { + $charged_or_src = + " AND ( charged_party = '$did' + OR ( ( charged_party IS NULL OR charged_party = '' ) + AND + src = '$did' + ) + ) + "; + + } + + qsearch( + 'select' => "$for_update *", + 'table' => 'cdr', + 'hashref' => { + #( freesidestatus IS NULL OR freesidestatus = '' ) + 'freesidestatus' => '', + }, + 'extra_sql' => $charged_or_src, + + ); + +} + =item radius_groups Returns all RADIUS groups for this account (see L<FS::radius_usergroup>). @@ -1350,6 +1833,8 @@ Returns all RADIUS groups for this account (see L<FS::radius_usergroup>). sub radius_groups { my $self = shift; if ( $self->usergroup ) { + confess "explicitly specified usergroup not an arrayref: ". $self->usergroup + unless ref($self->usergroup) eq 'ARRAY'; #when provisioning records, export callback runs in svc_Common.pm before #radius_usergroup records can be inserted... @{$self->usergroup}; @@ -1390,7 +1875,7 @@ sub clone_kludge_unsuspend { =item check_password Checks the supplied password against the (possibly encrypted) password in the -database. Returns true for a sucessful authentication, false for no match. +database. Returns true for a successful authentication, false for no match. Currently supported encryptions are: classic DES crypt() and MD5 @@ -1457,13 +1942,67 @@ sub crypt_password { } elsif ( $encryption eq 'md5' ) { unix_md5_crypt( $self->_password ); } elsif ( $encryption eq 'blowfish' ) { - die "unknown encryption method $encryption"; + croak "unknown encryption method $encryption"; } else { - die "unknown encryption method $encryption"; + croak "unknown encryption method $encryption"; } } } +=item ldap_password [ DEFAULT_ENCRYPTION_TYPE ] + +Returns an encrypted password in "LDAP" format, with a curly-bracked prefix +describing the format, for example, "{CRYPT}94pAVyK/4oIBk" or +"{PLAIN-MD5}5426824942db4253f87a1009fd5d2d4f". + +The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it +to work the same as the B</crypt_password> method. + +=cut + +sub ldap_password { + my $self = shift; + #eventually should check a "password-encoding" field + if ( length($self->_password) == 13 ) { #crypt + return '{CRYPT}'. $self->_password; + } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5 + return '{MD5}'. $1; + } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish + die "Blowfish encryption not supported in this context, svcnum ". + $self->svcnum. "\n"; + } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA + return '{SSHA}'. $1; + } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5 + return '{NS-MTA-MD5}'. $1; + } else { #plaintext + return '{PLAIN}'. $self->_password; + #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt'; + #if ( $encryption eq 'crypt' ) { + # return '{CRYPT}'. crypt( + # $self->_password, + # $saltset[int(rand(64))].$saltset[int(rand(64))] + # ); + #} elsif ( $encryption eq 'md5' ) { + # unix_md5_crypt( $self->_password ); + #} elsif ( $encryption eq 'blowfish' ) { + # croak "unknown encryption method $encryption"; + #} else { + # croak "unknown encryption method $encryption"; + #} + } +} + +=item domain_slash_username + +Returns $domain/$username/ + +=cut + +sub domain_slash_username { + my $self = shift; + $self->domain. '/'. $self->username. '/'; +} + =item virtual_maildir Returns $domain/maildirs/$username/ @@ -1637,6 +2176,82 @@ END $html; } +=item reached_threshold + +Performs some activities when svc_acct thresholds (such as number of seconds +remaining) are reached. + +=cut + +sub reached_threshold { + my %opt = @_; + + my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } ); + die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct; + + if ( $opt{'op'} eq '+' ){ + $svc_acct->setfield( $opt{'column'}.'_threshold', + int($svc_acct->getfield($opt{'column'}) + * ( $conf->exists('svc_acct-usage_threshold') + ? $conf->config('svc_acct-usage_threshold')/100 + : 0.80 + ) + ) + ); + my $error = $svc_acct->replace; + die $error if $error; + }elsif ( $opt{'op'} eq '-' ){ + + my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' ); + return '' if ($threshold eq '' ); + + $svc_acct->setfield( $opt{'column'}.'_threshold', 0 ); + my $error = $svc_acct->replace; + die $error if $error; # email next time, i guess + + if ( $warning_template ) { + eval "use FS::Misc qw(send_email)"; + die $@ if $@; + + my $cust_pkg = $svc_acct->cust_svc->cust_pkg; + my $cust_main = $cust_pkg->cust_main; + + my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } + $cust_main->invoicing_list, + $svc_acct->email, + ($opt{'to'} ? $opt{'to'} : ()) + ); + + my $mimetype = $warning_mimetype; + $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/; + + my $body = $warning_template->fill_in( HASH => { + 'custnum' => $cust_main->custnum, + 'username' => $svc_acct->username, + 'password' => $svc_acct->_password, + 'first' => $cust_main->first, + 'last' => $cust_main->getfield('last'), + 'pkg' => $cust_pkg->part_pkg->pkg, + 'column' => $opt{'column'}, + 'amount' => $svc_acct->getfield($opt{'column'}), + 'threshold' => $threshold, + } ); + + + my $error = send_email( + 'from' => $warning_from, + 'to' => $to, + 'subject' => $warning_subject, + 'content-type' => $mimetype, + 'body' => [ map "$_\n", split("\n", $body) ], + ); + die $error if $error; + } + }else{ + die "unknown op: " . $opt{'op'}; + } +} + =back =head1 BUGS diff --git a/FS/FS/svc_broadband.pm b/FS/FS/svc_broadband.pm index aaac891e6..ab97ac82c 100755 --- a/FS/FS/svc_broadband.pm +++ b/FS/FS/svc_broadband.pm @@ -85,8 +85,51 @@ points to. You can ask the object for a copy with the I<hash> method. =cut +sub table_info { + { + 'name' => 'Broadband', + 'name_plural' => 'Broadband services', + 'longname_plural' => 'Fixed (username-less) broadband services', + 'display_weight' => 50, + 'cancel_weight' => 70, + 'fields' => { + 'description' => 'Descriptive label for this particular device.', + 'speed_down' => 'Maximum download speed for this service in Kbps. 0 denotes unlimited.', + 'speed_up' => 'Maximum upload speed for this service in Kbps. 0 denotes unlimited.', + 'ip_addr' => 'IP address. Leave blank for automatic assignment.', + 'blocknum' => 'Address block.', + }, + }; +} + sub table { 'svc_broadband'; } +=item search_sql STRING + +Class method which returns an SQL fragment to search for the given string. + +=cut + +sub search_sql { + my( $class, $string ) = @_; + if ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) { + $class->search_sql_field('ip_addr', $string ); + } else { + '1 = 0'; #false + } +} + +=item label + +Returns the IP address. + +=cut + +sub label { + my $self = shift; + $self->ip_addr; +} + =item insert [ , OPTION => VALUE ... ] Adds this record to the database. If there is an error, returns the error, @@ -151,15 +194,29 @@ sub check { my $error = $self->ut_numbern('svcnum') || $self->ut_foreign_key('blocknum', 'addr_block', 'blocknum') + || $self->ut_textn('description') || $self->ut_number('speed_up') || $self->ut_number('speed_down') || $self->ut_ipn('ip_addr') + || $self->ut_hexn('mac_addr') + || $self->ut_hexn('auth_key') + || $self->ut_floatn('latitude') + || $self->ut_floatn('longitude') + || $self->ut_floatn('altitude') + || $self->ut_textn('vlan_profile') ; return $error if $error; if($self->speed_up < 0) { return 'speed_up must be positive'; } if($self->speed_down < 0) { return 'speed_down must be positive'; } + if($self->latitude < -90 || $self->latitude > 90) { + return 'latitude must be between -90 and 90'; + } + if($self->longitude < -180 || $self->longitude > 180) { + return 'longitude must be between -180 and 180'; + } + if (not($self->ip_addr) or $self->ip_addr eq '0.0.0.0') { my $next_addr = $self->addr_block->next_free_addr; if ($next_addr) { diff --git a/FS/FS/svc_domain.pm b/FS/FS/svc_domain.pm index 6d5435718..529127158 100644 --- a/FS/FS/svc_domain.pm +++ b/FS/FS/svc_domain.pm @@ -11,6 +11,7 @@ use Date::Format; use FS::Record qw(fields qsearch qsearchs dbh); use FS::Conf; use FS::svc_Common; +use FS::svc_Parent_Mixin; use FS::cust_svc; use FS::svc_acct; use FS::cust_pkg; @@ -18,7 +19,7 @@ use FS::cust_main; use FS::domain_record; use FS::queue; -@ISA = qw( FS::svc_Common ); +@ISA = qw( FS::svc_Parent_Mixin FS::svc_Common ); #ask FS::UID to run this stuff for us later $FS::UID::callback{'FS::domain'} = sub { @@ -72,6 +73,20 @@ FS::svc_Common. The following fields are currently supported: =item catchall - optional svcnum of an svc_acct record, designating an email catchall account. +=item suffix - + +=item parent_svcnum - + +=item registrarnum - Registrar (see L<FS::registrar>) + +=item registrarkey - Registrar key or password for this domain + +=item setup_date - UNIX timestamp + +=item renewal_interval - Number of days before expiration date to start renewal + +=item expiration_date - UNIX timestamp + =back =head1 METHODS @@ -84,8 +99,37 @@ Creates a new domain. To add the domain to the database, see L<"insert">. =cut +sub table_info { + { + 'name' => 'Domain', + 'sorts' => 'domain', + 'display_weight' => 20, + 'cancel_weight' => 60, + 'fields' => { + 'domain' => 'Domain', + }, + }; +} + sub table { 'svc_domain'; } +sub search_sql { + my($class, $string) = @_; + $class->search_sql_field('domain', $string); +} + + +=item label + +Returns the domain. + +=cut + +sub label { + my $self = shift; + $self->domain; +} + =item insert [ , OPTION => VALUE ... ] Adds this domain to the database. If there is an error, returns the error, @@ -141,15 +185,6 @@ sub insert { 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 ) { @@ -157,8 +192,6 @@ sub insert { return $error; } - $self->submit_internic unless $whois_hack; - if ( $soamachine ) { my $soa = new FS::domain_record { 'svcnum' => $self->svcnum, @@ -230,7 +263,11 @@ sub delete { my $error = $domain_record->delete; if ( $error ) { $dbh->rollback if $oldAutoCommit; - return $error; + return "can't delete DNS entry: ". + join(' ', map $domain_record->$_(), + qw( reczone recaf rectype recdata ) + ). + ":$error"; } } @@ -253,6 +290,9 @@ returns the error, otherwise returns false. sub replace { my ( $new, $old ) = ( shift, shift ); + # We absolutely have to have an old vs. new record to make this work. + $old = $new->replace_old unless defined($old); + return "Can't change domain - reorder." if $old->getfield('domain') ne $new->getfield('domain'); @@ -313,45 +353,32 @@ sub check { 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,63})\.(com|net|org|edu)$/ ) { + if ( $recref->{domain} =~ /^([\w\-]{1,63})\.(com|net|org|edu|tv|info|biz)$/ ) { $recref->{domain} = "$1.$2"; + $recref->{suffix} ||= $2; # hmmmmmmmm. - } elsif ( $whois_hack && $recref->{domain} =~ /^([\w\-\.]+)$/ ) { - $recref->{domain} = $1; + } elsif ( $whois_hack && $recref->{domain} =~ /^([\w\-\.]+)\.(\w+)$/ ) { + $recref->{domain} = "$1.$2"; + # need to match a list of suffixes - no guarantee they're top-level.. } else { return "Illegal domain ". $recref->{domain}. " (or unknown registry - try \$whois_hack)"; } - $recref->{action} =~ /^(M|N)$/ - or return "Illegal action: ". $recref->{action}; - $recref->{action} = $1; if ( $recref->{catchall} ne '' ) { my $svc_acct = qsearchs( 'svc_acct', { 'svcnum' => $recref->{catchall} } ); return "Unknown catchall" unless $svc_acct; } - $self->ut_textn('purpose') + $self->ut_alphan('suffix') + or $self->ut_foreign_keyn('registrarnum', 'registrar', 'registrarnum') + or $self->ut_textn('registrarkey') + or $self->ut_numbern('setup_date') + or $self->ut_numbern('renewal_interval') + or $self->ut_numbern('expiration_date') + or $self->ut_textn('purpose') or $self->SUPER::check; } @@ -364,16 +391,34 @@ sub domain_record { my $self = shift; my %order = ( - SOA => 1, - NS => 2, - MX => 3, - CNAME => 4, - A => 5, - TXT => 6, + 'SOA' => 1, + 'NS' => 2, + 'MX' => 3, + 'CNAME' => 4, + 'A' => 5, + 'TXT' => 6, + 'PTR' => 7, + ); + + my %sort = ( + #'SOA' => sub { $_[0]->recdata cmp $_[1]->recdata }, #sure hope not though +# 'SOA' => sub { 0; }, +# 'NS' => sub { 0; }, + 'MX' => sub { my( $a_weight, $a_name ) = split(/\s+/, $_[0]->recdata); + my( $b_weight, $b_name ) = split(/\s+/, $_[1]->recdata); + $a_weight <=> $b_weight or $a_name cmp $b_name; + }, + 'CNAME' => sub { $_[0]->reczone cmp $_[1]->reczone }, + 'A' => sub { $_[0]->reczone cmp $_[1]->reczone }, + +# 'TXT' => sub { 0; }, + 'PTR' => sub { $_[0]->reczone <=> $_[1]->reczone }, ); - sort { $order{$a->rectype} <=> $order{$b->rectype} } - qsearch('domain_record', { svcnum => $self->svcnum } ); + sort { $order{$a->rectype} <=> $order{$b->rectype} + or &{ $sort{$a->rectype} || sub { 0; } }($a, $b) + } + qsearch('domain_record', { svcnum => $self->svcnum } ); } @@ -397,7 +442,7 @@ sub catchall_svc_acct { sub whois { #$whois_hack or new Net::Whois::Domain $_[0]->domain; - $whois_hack or die "whois_hack not set...\n"; + #$whois_hack or die "whois_hack not set...\n"; } =item _whois diff --git a/FS/FS/svc_external.pm b/FS/FS/svc_external.pm index 79eec97c4..5aaee4872 100644 --- a/FS/FS/svc_external.pm +++ b/FS/FS/svc_external.pm @@ -1,16 +1,11 @@ package FS::svc_external; use strict; -use vars qw(@ISA); # $conf -use FS::UID; -#use FS::Record qw( qsearch qsearchs dbh); -use FS::svc_Common; +use vars qw(@ISA); +use FS::Conf; +use FS::svc_External_Common; -@ISA = qw( FS::svc_Common ); - -#FS::UID::install_callback( sub { -# $conf = new FS::Conf; -#}; +@ISA = qw( FS::svc_External_Common ); =head1 NAME @@ -39,9 +34,9 @@ FS::svc_external - Object methods for svc_external records =head1 DESCRIPTION -An FS::svc_external object represents a externally tracked service. -FS::svc_external inherits from FS::svc_Common. The following fields are -currently supported: +An FS::svc_external object represents a generic externally tracked service. +FS::svc_external inherits from FS::svc_External_Common (and FS::svc_Common). +The following fields are currently supported: =over 4 @@ -67,8 +62,31 @@ points to. You can ask the object for a copy with the I<hash> method. =cut +sub table_info { + { + 'name' => 'External service', + 'sorts' => 'id', + 'display_weight' => 90, + 'cancel_weight' => 10, + 'fields' => { + }, + }; +} + sub table { 'svc_external'; } +# oh! this should be moved to svc_artera_turbo or something now +sub label { + my $self = shift; + my $conf = new FS::Conf; + if ( $conf->config('svc_external-display_type') eq 'artera_turbo' ) { + sprintf('%010d', $self->id). '-'. + substr('0000000000'.uc($self->title), -10); + } else { + $self->SUPER::label; + } +} + =item insert [ , OPTION => VALUE ... ] Adds this external service to the database. If there is an error, returns the @@ -145,25 +163,19 @@ Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>). Checks all fields to make sure this is a valid external service. If there is an error, returns the error, otherwise returns false. Called by the insert -and repalce methods. +and replace 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_numbern('id') - || $self->ut_textn('title') - ; - - $self->SUPER::check; -} +#sub check { +# my $self = shift; +# my $error; +# +# $error = $self->SUPER::delete; +# return $error if $error; +# +# ''; +#} =back @@ -171,8 +183,8 @@ sub check { =head1 SEE ALSO -L<FS::svc_Common>, L<FS::Record>, L<FS::cust_svc>, L<FS::part_svc>, -L<FS::cust_pkg>, schema.html from the base documentation. +L<FS::svc_External_Common>, L<FS::svc_Common>, L<FS::Record>, L<FS::cust_svc>, +L<FS::part_svc>, L<FS::cust_pkg>, schema.html from the base documentation. =cut diff --git a/FS/FS/svc_forward.pm b/FS/FS/svc_forward.pm index 12b556f33..91e251fa0 100644 --- a/FS/FS/svc_forward.pm +++ b/FS/FS/svc_forward.pm @@ -66,8 +66,67 @@ database, see L<"insert">. =cut + +sub table_info { + { + 'name' => 'Forward', + 'name_plural' => 'Mail forwards', + 'display_weight' => 30, + 'cancel_weight' => 30, + 'fields' => { + 'srcsvc' => 'service from which mail is to be forwarded', + 'dstsvc' => 'service to which mail is to be forwarded', + 'dst' => 'someone@another.domain.com to use when dstsvc is 0', + }, + }; +} + sub table { 'svc_forward'; } +=item search_sql STRING + +Class method which returns an SQL fragment to search for the given string. + +=cut + +sub search_sql { + my( $class, $string ) = @_; + $class->search_sql_field('src', $string); +} + +=item label [ END_TIMESTAMP [ START_TIMESTAMP ] ] + +Returns a text string representing this forward. + +END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with +history records. + +=cut + +sub label { + my $self = shift; + my $tag = ''; + + if ( $self->srcsvc ) { + my $svc_acct = $self->srcsvc_acct(@_); + $tag = $svc_acct->email(@_); + } else { + $tag = $self->src; + } + + $tag .= ' -> '; + + if ( $self->dstsvc ) { + my $svc_acct = $self->dstsvc_acct(@_); + $tag .= $svc_acct->email(@_); + } else { + $tag .= $self->dst; + } + + $tag; +} + + =item insert [ , OPTION => VALUE ... ] Adds this mail forwarding alias to the database. If there is an error, returns @@ -257,9 +316,15 @@ sub check { } if ( $self->dst ) { - $self->dst =~ /^([\w\.\-\&]*)(\@([\w\-]+\.)+\w+)$/ - or return "Illegal dst: ". $self->dst; - $self->dst("$1$2"); + my $conf = new FS::Conf; + if ( $conf->exists('svc_forward-arbitrary_dst') ) { + my $error = $self->ut_textn('dst'); + return $error if $error; + } else { + $self->dst =~ /^([\w\.\-\&]*)(\@([\w\-]+\.)+\w+)$/ + or return "Illegal dst: ". $self->dst; + $self->dst("$1$2"); + } } else { $self->dst(''); } diff --git a/FS/FS/svc_phone.pm b/FS/FS/svc_phone.pm new file mode 100644 index 000000000..00ccc1958 --- /dev/null +++ b/FS/FS/svc_phone.pm @@ -0,0 +1,190 @@ +package FS::svc_phone; + +use strict; +use vars qw( @ISA ); +#use FS::Record qw( qsearch qsearchs ); +use FS::svc_Common; + +@ISA = qw( FS::svc_Common ); + +=head1 NAME + +FS::svc_phone - Object methods for svc_phone records + +=head1 SYNOPSIS + + use FS::svc_phone; + + $record = new FS::svc_phone \%hash; + $record = new FS::svc_phone { '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_phone object represents a phone number. FS::svc_phone inherits +from FS::Record. The following fields are currently supported: + +=over 4 + +=item svcnum - primary key + +=item countrycode - + +=item phonenum - + +=item pin - + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new phone number. To add the number 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_info { + { + 'name' => 'Phone number', + 'sorts' => 'phonenum', + 'display_weight' => 60, + 'cancel_weight' => 80, + 'fields' => { + 'countrycode' => { label => 'Country code', + type => 'text', + disable_inventory => 1, + disable_select => 1, + }, + 'phonenum' => 'Phone number', + 'pin' => { label => 'Personal Identification Number', + type => 'text', + disable_inventory => 1, + disable_select => 1, + }, + }, + }; +} + +sub table { 'svc_phone'; } + +=item search_sql STRING + +Class method which returns an SQL fragment to search for the given string. + +=cut + +sub search_sql { + my( $class, $string ) = @_; + $class->search_sql_field('phonenum', $string ); +} + +=item label + +Returns the phone number. + +=cut + +sub label { + my $self = shift; + $self->phonenum; #XXX format it better +} + +=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 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 phone number. 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('svcnum') + || $self->ut_numbern('countrycode') + || $self->ut_number('phonenum') + || $self->ut_numbern('pin') + ; + return $error if $error; + + $self->countrycode(1) unless $self->countrycode; + + $self->SUPER::check; +} + +=back + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::svc_Common>, L<FS::Record>, L<FS::cust_svc>, L<FS::part_svc>, +L<FS::cust_pkg>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/svc_www.pm b/FS/FS/svc_www.pm index 12d7e92f3..066719bbe 100644 --- a/FS/FS/svc_www.pm +++ b/FS/FS/svc_www.pm @@ -72,8 +72,33 @@ points to. You can ask the object for a copy with the I<hash> method. =cut +sub table_info { + { + 'name' => 'Hosting', + 'name_plural' => 'Virtual hosting services', + 'display_weight' => 40, + 'cancel_weight' => 20, + 'fields' => { + }, + }; +}; + sub table { 'svc_www'; } +=item label [ END_TIMESTAMP [ START_TIMESTAMP ] ] + +Returns the zone name for this virtual host. + +END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with +history records. + +=cut + +sub label { + my $self = shift; + $self->domain_record(@_)->zone; +} + =item insert [ , OPTION => VALUE ... ] Adds this record to the database. If there is an error, returns the error, @@ -190,7 +215,7 @@ Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>). 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. +and replace methods. =cut diff --git a/FS/MANIFEST b/FS/MANIFEST index e7d9dea34..82f106412 100644 --- a/FS/MANIFEST +++ b/FS/MANIFEST @@ -5,9 +5,9 @@ Makefile.PL README bin/freeside-addoutsource bin/freeside-addoutsourceuser +bin/freeside-addgroup bin/freeside-adduser bin/freeside-apply-credits -bin/freeside-bill bin/freeside-count-active-customers bin/freeside-daily bin/freeside-deloutsource @@ -25,6 +25,7 @@ bin/freeside-sqlradius-radacctd bin/freeside-sqlradius-reset bin/freeside-sqlradius-seconds FS.pm +FS/AccessRight.pm FS/CGI.pm FS/InitHandler.pm FS/ClientAPI.pm @@ -33,6 +34,9 @@ FS/ClientAPI/passwd.pm FS/ClientAPI/MyAccount.pm FS/Conf.pm FS/ConfItem.pm +FS/Cron/backup.pm +FS/Cron/bill.pm +FS/Cron/vacuum.pm FS/Daemon.pm FS/Misc.pm FS/Record.pm @@ -43,6 +47,7 @@ FS/SearchCache.pm FS/UI/Web.pm FS/UID.pm FS/Msgcat.pm +FS/Pony.pm FS/acct_snarf.pm FS/agent.pm FS/agent_type.pm @@ -65,7 +70,9 @@ FS/cust_refund.pm FS/cust_credit_refund.pm FS/cust_svc.pm FS/h_Common.pm +FS/h_cust_bill.pm FS/h_cust_svc.pm +FS/h_cust_tax_exempt.pm FS/h_domain_record.pm FS/h_svc_acct.pm FS/h_svc_broadband.pm @@ -74,6 +81,7 @@ FS/h_svc_external.pm FS/h_svc_forward.pm FS/h_svc_www.pm FS/part_bill_event.pm +FS/payinfo_Mixin.pm FS/export_svc.pm FS/part_export.pm FS/part_export_option.pm @@ -117,12 +125,15 @@ FS/part_pkg/sql_generic.pm FS/part_pkg/sqlradacct_hour.pm FS/part_pkg/subscription.pm FS/part_pkg/voip_sqlradacct.pm +FS/part_pkg/voip_cdr.pm FS/part_pop_local.pm FS/part_referral.pm FS/part_svc.pm FS/part_svc_column.pm FS/part_svc_router.pm FS/part_virtual_field.pm +FS/payby.pm +FS/pkg_class.pm FS/pkg_svc.pm FS/rate.pm FS/rate_detail.pm @@ -152,16 +163,21 @@ FS/queue_arg.pm FS/queue_depend.pm FS/msgcat.pm FS/cust_tax_exempt.pm +FS/cust_tax_exempt_pkg.pm FS/clientapi_session.pm FS/clientapi_session_field.pm t/agent.t t/agent_type.t +t/AccessRight.t t/CGI.t t/InitHandler.t t/ClientAPI.t t/ClientAPI_SessionCache.t t/Conf.t t/ConfItem.t +t/Cron-backup.t +t/Cron-bill.t +t/Cron-vacuum.t t/Daemon.t t/Misc.t t/Record.t @@ -189,7 +205,9 @@ t/cust_pay_refund.t t/cust_pkg.t t/cust_refund.t t/cust_svc.t +t/h_cust_bill.t t/h_cust_svc.t +t/h_cust_tax_exempt.t t/h_Common.t t/h_cust_svc.t t/h_domain_record.t @@ -200,6 +218,7 @@ t/h_svc_external.t t/h_svc_forward.t t/h_svc_www.t t/cust_tax_exempt.t +t/cust_tax_exempt_pkg.t t/domain_record.t t/nas.t t/part_bill_event.t @@ -248,10 +267,14 @@ t/part_pkg-sql_generic.t t/part_pkg-sqlradacct_hour.t t/part_pkg-subscription.t t/part_pkg-voip_sqlradacct.t +t/part_pkg-voip_cdr.t t/part_pop_local.t t/part_referral.t t/part_svc.t t/part_svc_column.t +t/payby.t +t/payinfo_Mixin.t +t/pkg_class.t t/pkg_svc.t t/port.t t/prepay_credit.t @@ -289,6 +312,62 @@ FS/agent_payment_gateway.pm t/agent_payment_gateway.t FS/banned_pay.pm t/banned_pay.t -FS/cancel_reason.pm -t/cancel_reason.t bin/freeside-prepaidd +FS/cdr.pm +t/cdr.t +FS/cdr_calltype.pm +t/cdr_calltype.t +FS/cdr_type.pm +t/cdr_type.t +FS/cdr_carrier.pm +t/cdr_carrier.t +FS/inventory_class.pm +t/inventory_class.t +FS/inventory_item.pm +t/inventory_item.t +FS/cdr_upstream_rate.pm +t/cdr_upstream_rate.t +FS/access_user.pm +t/access_user.t +FS/access_user_pref.pm +t/access_user_pref.t +FS/access_group.pm +t/access_group.t +FS/access_usergroup.pm +t/access_usergroup.t +FS/access_groupagent.pm +t/access_groupagent.t +FS/access_right.pm +t/access_right.t +FS/m2m_Common.pm +FS/pay_batch.pm +t/pay_batch.t +FS/ConfDefaults.pm +t/ConfDefaults.t +FS/m2name_Common.pm +FS/CurrentUser.pm +FS/svc_phone.pm +t/svc_phone.t +FS/h_svc_phone.pm +FS/cust_bill_pay_batch.pm +t/cust_bill_pay_batch.t +FS/cust_bill_pay_pkg.pm +t/cust_bill_pay_pkg.t +FS/cust_credit_bill_pkg.pm +t/cust_credit_bill_pkg.t +FS/registrar.pm +t/registrar.t +FS/svc_External_Common.pm +t/svc_External_Common.t +FS/svc_Parent_Mixin.pm +t/svc_Parent_Mixin.t +FS/cust_main_note.pm +t/cust_main_note.t +FS/cust_pkg_reason.pm +t/cust_pkg_reason.t +FS/reason.pm +t/reason.t +FS/reason_type.pm +t/reason_type.t +FS/cust_pkg_option.pm +t/cust_pkg_option.t diff --git a/FS/bin/freeside-addgroup b/FS/bin/freeside-addgroup new file mode 100755 index 000000000..7b30f7d95 --- /dev/null +++ b/FS/bin/freeside-addgroup @@ -0,0 +1,50 @@ +#!/usr/bin/perl + +use strict; +use vars qw($opt_s); +use Getopt::Std; +use FS::UID qw(adminsuidsetup); +use FS::Record qw(qsearch); +use FS::CurrentUser; +use FS::AccessRight; +use FS::access_group; +use FS::access_right; +use FS::access_groupagent; + +getopts("s"); +my $user = shift or die &usage; #just for adminsuidsetup +my $group = shift or die &usage; + +$FS::CurrentUser::upgrade_hack = 1; +#adminsuidsetup $rootuser; +adminsuidsetup $user; + +my $access_group = new FS::access_group { 'groupname' => $group }; +my $error = $access_group->insert; +die $error if $error; + +if ( $opt_s ) { + foreach my $rightname ( FS::AccessRight->rights ) { + my $access_right = new FS::access_right { + 'righttype' => 'FS::access_group', + 'rightobjnum' => $access_group->groupnum, + 'rightname' => $rightname, + }; + my $ar_error = $access_right->insert; + die $ar_error if $ar_error; + } + + foreach my $agent ( qsearch('agent', {} ) ) { + my $access_groupagent = new FS::access_groupagent { + 'groupnum' => $access_group->groupnum, + 'agentnum' => $agent->agentnum, + }; + my $aga_error = $access_groupagent->insert; + die $aga_error if $aga_error; + } +} + +sub usage { + die "Usage:\n\n freeside-addgroup [ -s ] username groupname" +} + diff --git a/FS/bin/freeside-addoutsource b/FS/bin/freeside-addoutsource index db4e7a307..9cb12195a 100644 --- a/FS/bin/freeside-addoutsource +++ b/FS/bin/freeside-addoutsource @@ -2,23 +2,31 @@ domain=$1 +FREESIDE_CONF=%%%FREESIDE_CONF%%% +FREESIDE_CACHE=%%%FREESIDE_CACHE%%% +FREESIDE_EXPORT=%%%FREESIDE_EXPORT%%% + +#without this, [a-z]* matches CVS/, the copy doesn't return a sucessful error +# status, and the rest of the commands aren't run +export LANG=C + createdb $domain && \ \ -mkdir /usr/local/etc/freeside/conf.DBI:Pg:dbname=$domain && \ +mkdir $FREESIDE_CONF/conf.DBI:Pg:dbname=$domain && \ \ -chown freeside /usr/local/etc/freeside/conf.DBI:Pg:dbname=$domain && \ +chown freeside $FREESIDE_CONF/conf.DBI:Pg:dbname=$domain && \ \ -cp /home/ivan/freeside/conf/[a-z]* /usr/local/etc/freeside/conf.DBI:Pg:dbname=$domain && \ +cp /home/ivan/freeside/conf/[a-z]* $FREESIDE_CONF/conf.DBI:Pg:dbname=$domain && \ \ -touch /usr/local/etc/freeside/conf.DBI:Pg:dbname=$domain/secrets && \ +touch $FREESIDE_CONF/conf.DBI:Pg:dbname=$domain/secrets && \ \ -chown freeside /usr/local/etc/freeside/conf.DBI:Pg:dbname=$domain/secrets && \ +chown freeside $FREESIDE_CONF/conf.DBI:Pg:dbname=$domain/secrets && \ \ -chmod 600 /usr/local/etc/freeside/conf.DBI:Pg:dbname=$domain/secrets && \ +chmod 600 $FREESIDE_CONF/conf.DBI:Pg:dbname=$domain/secrets && \ \ -echo -e "DBI:Pg:dbname=$domain\nfreeside\n" >/usr/local/etc/freeside/conf.DBI:Pg:dbname=$domain/secrets && \ +echo -e "DBI:Pg:dbname=$domain\nfreeside\n" >$FREESIDE_CONF/conf.DBI:Pg:dbname=$domain/secrets && \ \ -mkdir /usr/local/etc/freeside/counters.DBI:Pg:dbname=$domain && \ -mkdir /usr/local/etc/freeside/cache.DBI:Pg:dbname=$domain && \ -mkdir /usr/local/etc/freeside/export.DBI:Pg:dbname=$domain +mkdir $FREESIDE_CACHE/counters.DBI:Pg:dbname=$domain && \ +mkdir $FREESIDE_CACHE/cache.DBI:Pg:dbname=$domain && \ +mkdir $FREESIDE_EXPORT/export.DBI:Pg:dbname=$domain diff --git a/FS/bin/freeside-addoutsourceuser b/FS/bin/freeside-addoutsourceuser index cad07f1fd..cbe792acc 100644 --- a/FS/bin/freeside-addoutsourceuser +++ b/FS/bin/freeside-addoutsourceuser @@ -3,13 +3,16 @@ username=$1 domain=$2 password=$3 +realdomain=$4 +FREESIDE_CONF=%%%FREESIDE_CONF%%% -freeside-adduser -h /usr/local/etc/freeside/htpasswd \ - -s conf.DBI:Pg:dbname=$domain/secrets \ - -b \ - $username $password 2>/dev/null +freeside-adduser -s conf.DBI:Pg:dbname=$domain/secrets \ + -n \ + $username #2>/dev/null -[ -e /usr/local/etc/freeside/dbdef.DBI:Pg:dbname=$domain ] \ - || ( freeside-setup -s $username 2>/dev/null; \ - /home/ivan/freeside/bin/populate-msgcat $username 2>/dev/null ) +[ -e $FREESIDE_CONF/dbdef.DBI:Pg:dbname=$domain ] \ + || ( freeside-setup -d $realdomain -u $username ) +freeside-adduser -g 1 $username + +htpasswd -b $FREESIDE_CONF/htpasswd $username $password diff --git a/FS/bin/freeside-adduser b/FS/bin/freeside-adduser index c3ee05b9b..237e29ef8 100644 --- a/FS/bin/freeside-adduser +++ b/FS/bin/freeside-adduser @@ -1,37 +1,85 @@ #!/usr/bin/perl -w -# -# $Id: freeside-adduser,v 1.8 2002-09-27 05:36:29 ivan Exp $ use strict; -use vars qw($opt_h $opt_b $opt_c $opt_s); +use vars qw($opt_s $opt_g $opt_n); use Fcntl qw(:flock); use Getopt::Std; -my $FREESIDE_CONF = "/usr/local/etc/freeside"; +my $FREESIDE_CONF = "%%%FREESIDE_CONF%%%"; -getopts("bch:s:"); -die &usage if $opt_c && ! $opt_h; +getopts("s:g:n"); my $user = shift or die &usage; -if ( $opt_h ) { - my @args = ( 'htpasswd' ); - push @args, '-b' if $opt_b; - push @args, '-c' if $opt_c; - push @args, $opt_h, $user; - push @args, shift if $opt_b; - system(@args) == 0 or die "htpasswd failed: $?"; +if ( $opt_s ) { + + #if ( -e "$FREESIDE_CONF/mapsecrets" ) { + # open(MAPSECRETS,"<$FREESIDE_CONF/mapsecrets") + # or die "can't open $FREESIDE_CONF/mapsecrets: $!"; + # while (<MAPSECRETS>) { + # /^(\S+) / or die "unparsable line in mapsecrets: $_"; + # die "user $user already exists\n" if $user eq $1; + # } + # close MAPSECRETS; + #} + + #insert new entry before a wildcard... + open(MAPSECRETS,"<$FREESIDE_CONF/mapsecrets") + and flock(MAPSECRETS,LOCK_EX) + or die "can't open $FREESIDE_CONF/mapsecrets: $!"; + open(NEW,">$FREESIDE_CONF/mapsecrets.new") + or die "can't open $FREESIDE_CONF/mapsecrets.new: $!"; + while(<MAPSECRETS>) { + if ( /^\*\s/ ) { + print NEW "$user $opt_s\n"; + } + print NEW $_; + } + close MAPSECRETS or die "can't close $FREESIDE_CONF/mapsecrets: $!"; + close NEW or die "can't close $FREESIDE_CONF/mapsecrets.new: $!"; + rename("$FREESIDE_CONF/mapsecrets.new", "$FREESIDE_CONF/mapsecrets") + or die "can't move mapsecrets.new into place: $!"; + } -my $secretfile = $opt_s || 'secrets'; +### + +exit if $opt_n; + +### + +use FS::UID qw(adminsuidsetup); +use FS::CurrentUser; +use FS::access_user; +use FS::access_usergroup; + +$FS::CurrentUser::upgrade_hack = 1; +#adminsuidsetup $rootuser; +adminsuidsetup $user; + +my $access_user = new FS::access_user { + 'username' => $user, + '_password' => 'notyet', + 'first' => 'Firstname', # $opt_f || + 'last' => 'Lastname', # $opt_l || +}; +my $au_error = $access_user->insert; +die $au_error if $au_error; + +if ( $opt_g ) { -open(MAPSECRETS,">>$FREESIDE_CONF/mapsecrets") - and flock(MAPSECRETS,LOCK_EX) - or die "can't open $FREESIDE_CONF/mapsecrets: $!"; -print MAPSECRETS "$user $secretfile\n"; -close MAPSECRETS or die "can't close $FREESIDE_CONF/mapsecrets: $!"; + my $access_usergroup = new FS::access_usergroup { + 'usernum' => $access_user->usernum, + 'groupnum' => $opt_g, + }; + my $aug_error = $access_usergroup->insert; + die $aug_error if $aug_error; + +} + +### sub usage { - die "Usage:\n\n freeside-adduser [ -h htpasswd_file [ -c ] [ -b ] ] [ -s secretfile ] username" + die "Usage:\n\n freeside-adduser [ -n ] [ -s ] [ -g groupnum ] username [ password ]" } =head1 NAME @@ -40,24 +88,32 @@ freeside-adduser - Command line interface to add (freeside) users. =head1 SYNOPSIS - freeside-adduser [ -h htpasswd_file [ -c ] ] [ -s secretfile ] username + freeside-adduser [ -n ] [ -s ] [ -g groupnum ] username [ password ] =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 +This functionality is now available in the web interface as well, under +B<Configuration | Employees | View/Edit employees>. + + -g: initial groupnum + + Development/multi-DB options: + + -s: alternate secrets file - -c: Passed to htpasswd(1) + -n: no ACL added, for bootstrapping - -s: Specify an alternate secret file +=head1 NOTE - -b: same as htpasswd(1), probably insecure, not recommended +No explicit htpasswd options are available in 1.7 - passwordsa are now +maintained automatically. =head1 SEE ALSO -L<htpasswd>(1), base Freeside documentation +Base Freeside documentation =cut diff --git a/FS/bin/freeside-bill b/FS/bin/freeside-bill deleted file mode 100755 index 49ad4a768..000000000 --- a/FS/bin/freeside-bill +++ /dev/null @@ -1,128 +0,0 @@ -#!/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-daily b/FS/bin/freeside-daily index 603da12b8..a06a2b185 100755 --- a/FS/bin/freeside-daily +++ b/FS/bin/freeside-daily @@ -1,157 +1,32 @@ #!/usr/bin/perl -w use strict; -use Fcntl qw(:flock); -use Date::Parse; use Getopt::Std; -use FS::UID qw(adminsuidsetup driver_name dbh datasrc); -use FS::Record qw(qsearch qsearchs dbdef); -use FS::Conf; -use FS::cust_main; +use FS::UID qw(adminsuidsetup); &untaint_argv; #what it sounds like (eww) -use vars qw($opt_d $opt_v $opt_p $opt_a $opt_s $opt_y); -getopts("p:a:d:vsy:"); -my $user = shift or die &usage; +#use vars qw($opt_d $opt_v $opt_p $opt_a $opt_s $opt_y); +use vars qw(%opt); +getopts("p:a:d:vsy:", \%opt); +my $user = shift or die &usage; adminsuidsetup $user; -$FS::cust_main::DEBUG = 1 if $opt_v; - -my %search = (); -$search{'payby'} = $opt_p if $opt_p; -$search{'agentnum'} = $opt_a if $opt_a; - -#we're at now now (and later). -my($time)= $opt_d ? str2time($opt_d) : $^T; -$time += $opt_y * 86400 if $opt_y; - -# select * from cust_main where -my $where_pkg = <<"END"; - 0 < ( select count(*) from cust_pkg - where cust_main.custnum = cust_pkg.custnum - and ( cancel is null or cancel = 0 ) - and ( setup is null or setup = 0 - or bill is null or bill <= $time - or ( expire is not null and expire <= $^T ) - ) - ) -END - -# or -my $where_bill_event = <<"END"; - 0 < ( select count(*) from cust_bill - where cust_main.custnum = cust_bill.custnum - and 0 < charged - - coalesce( - ( select sum(amount) from cust_bill_pay - where cust_bill.invnum = cust_bill_pay.invnum ) - ,0 - ) - - coalesce( - ( select sum(amount) from cust_credit_bill - where cust_bill.invnum = cust_credit_bill.invnum ) - ,0 - ) - and 0 < ( select count(*) from part_bill_event - where payby = cust_main.payby - and ( disabled is null or disabled = '' ) - and seconds <= $time - cust_bill._date - and 0 = ( select count(*) from cust_bill_event - where cust_bill.invnum = cust_bill_event.invnum - and part_bill_event.eventpart = cust_bill_event.eventpart - and status = 'done' - ) - - ) - ) -END - -my $extra_sql = ( scalar(%search) ? ' AND ' : ' WHERE ' ). "( $where_pkg OR $where_bill_event )"; - -my @cust_main; -if ( @ARGV ) { - @cust_main = map { qsearchs('cust_main', { custnum => $_, %search } ) } @ARGV -} else { - @cust_main = qsearch('cust_main', \%search, '', $extra_sql ); -} -; - -my($cust_main,%saw); -foreach $cust_main ( @cust_main ) { - - # $^T not $time because -d is for pre-printing invoices - foreach my $cust_pkg ( - grep { $_->expire && $_->expire <= $^T } $cust_main->ncancelled_pkgs - ) { - my $error = $cust_pkg->cancel; - warn "Error cancelling expired pkg ". $cust_pkg->pkgnum. " for custnum ". - $cust_main->custnum. ": $error" - if $error; - } - # $^T not $time because -d is for pre-printing invoices - foreach my $cust_pkg ( - grep { $_->part_pkg->is_prepaid - && $_->bill && $_->bill < $^T && ! $_->susp - } - $cust_main->ncancelled_pkgs - ) { - my $error = $cust_pkg->suspend; - warn "Error suspending package ". $cust_pkg->pkgnum. - " for custnum ". $cust_main->custnum. - ": $error" - if $error; - } - - my $error = $cust_main->bill( 'time' => $time, - 'resetup' => $opt_s, ); - 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; +use FS::Cron::bill qw(bill); +bill(%opt); -} +use FS::Cron::notify qw(notify_flat_delay); +notify_flat_delay(%opt); -if ( driver_name eq 'Pg' ) { - dbh->{AutoCommit} = 1; #so we can vacuum - foreach my $table ( dbdef->tables ) { - my $sth = dbh->prepare("VACUUM ANALYZE $table") or die dbh->errstr; - $sth->execute or die $sth->errstr; - } -} +use FS::Cron::vacuum qw(vacuum); +vacuum(); -my $conf = new FS::Conf; -my $dest = $conf->config('dump-scpdest'); -if ( $dest ) { - datasrc =~ /dbname=([\w\.]+)$/ or die "unparsable datasrc ". datasrc; - my $database = $1; - eval "use Net::SCP qw(scp);"; - if ( driver_name eq 'Pg' ) { - system("pg_dump $database >/var/tmp/$database.sql") - } else { - die "database dumps not yet supported for ". driver_name; - } - if ( $conf->config('dump-pgpid') ) { - eval 'use GnuPG'; - my $gpg = new GnuPG; - $gpg->encrypt( plaintext => "/var/tmp/$database.sql", - output => "/var/tmp/$database.gpg", - recipient => $conf->config('dump-pgpid'), - ); - chmod 0600, '/var/tmp/$database.gpg'; - scp("/var/tmp/$database.gpg", $dest); - unlink "/var/tmp/$database.gpg" or die $!; - } else { - chmod 0600, '/var/tmp/$database.sql'; - scp("/var/tmp/$database.sql", $dest); - } - unlink "/var/tmp/$database.sql" or die $!; -} +use FS::Cron::backup qw(backup_scp); +backup_scp(); +### # subroutines +### sub untaint_argv { foreach $_ ( $[ .. $#ARGV ) { #untaint @ARGV @@ -166,6 +41,10 @@ sub usage { die "Usage:\n\n freeside-daily [ -d 'date' ] user [ custnum custnum ... ]\n"; } +### +# documentation +### + =head1 NAME freeside-daily - Run daily billing and invoice collection events. @@ -179,8 +58,6 @@ freeside-daily - Run daily billing and invoice collection events. 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>. diff --git a/FS/bin/freeside-deloutsource b/FS/bin/freeside-deloutsource index 561853539..afc3a0118 100644 --- a/FS/bin/freeside-deloutsource +++ b/FS/bin/freeside-deloutsource @@ -1,11 +1,14 @@ #!/bin/sh domain=$1 +FREESIDE_CONF=%%%FREESIDE_CONF%%% +FREESIDE_CACHE=%%%FREESIDE_CACHE%%% +FREESIDE_EXPORT=%%%FREESIDE_EXPORT%%% dropdb $domain && \ -rm -rf /usr/local/etc/freeside/conf.DBI:Pg:host=localhost\;dbname=$domain && \ -rm -rf /usr/local/etc/freeside/counters.DBI:Pg:host=localhost\;dbname=$domain && \ -rm -rf /usr/local/etc/freeside/cache.DBI:Pg:host=localhost\;dbname=$domain && \ -rm -rf /usr/local/etc/freeside/export.DBI:Pg:host=localhost\;dbname=$domain && \ -rm /usr/local/etc/freeside/dbdef.DBI:Pg:host=localhost\;dbname=$domain +rm -rf $FREESIDE_CONF/conf.DBI:Pg:host=localhost\;dbname=$domain && \ +rm -rf $FREESIDE_CACHE/counters.DBI:Pg:host=localhost\;dbname=$domain && \ +rm -rf $FREESIDE_CACHE/cache.DBI:Pg:host=localhost\;dbname=$domain && \ +rm -rf $FREESIDE_EXPORT/export.DBI:Pg:host=localhost\;dbname=$domain && \ +rm $FREESIDE_CONF/dbdef.DBI:Pg:host=localhost\;dbname=$domain diff --git a/FS/bin/freeside-deloutsourceuser b/FS/bin/freeside-deloutsourceuser index 96871e50c..dc4ff9cdc 100644 --- a/FS/bin/freeside-deloutsourceuser +++ b/FS/bin/freeside-deloutsourceuser @@ -2,5 +2,5 @@ username=$1 -freeside-deluser -h /usr/local/etc/freeside/htpasswd $username 2>/dev/null +freeside-deluser -h %%%FREESIDE_CONF%%%/htpasswd $username 2>/dev/null diff --git a/FS/bin/freeside-deluser b/FS/bin/freeside-deluser index 57d6ce165..a2a361a83 100644 --- a/FS/bin/freeside-deluser +++ b/FS/bin/freeside-deluser @@ -5,7 +5,7 @@ use vars qw($opt_h); use Fcntl qw(:flock); use Getopt::Std; -my $FREESIDE_CONF = "/usr/local/etc/freeside"; +my $FREESIDE_CONF = "%%%FREESIDE_CONF%%%"; getopts("h:"); my $user = shift or die &usage; diff --git a/FS/bin/freeside-email b/FS/bin/freeside-email index 400dc2ac7..7a93f78ee 100755 --- a/FS/bin/freeside-email +++ b/FS/bin/freeside-email @@ -47,10 +47,6 @@ 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.2 2002-09-18 22:50:44 ivan Exp $ - =head1 BUGS =head1 SEE ALSO diff --git a/FS/bin/freeside-expiration-alerter b/FS/bin/freeside-expiration-alerter index 691fd3aa5..e49bd62aa 100755 --- a/FS/bin/freeside-expiration-alerter +++ b/FS/bin/freeside-expiration-alerter @@ -200,10 +200,6 @@ is about to expire. Usually run as a cron job. user: From the mapsecrets file - see config.html from the base documentation -=head1 VERSION - -$Id: freeside-expiration-alerter,v 1.5 2003-04-21 20:53:57 ivan Exp $ - =head1 BUGS Yes..... Use at your own risk. No guarantees or warrantees of any diff --git a/FS/bin/freeside-monthly b/FS/bin/freeside-monthly new file mode 100755 index 000000000..a6c75e715 --- /dev/null +++ b/FS/bin/freeside-monthly @@ -0,0 +1,91 @@ +#!/usr/bin/perl -w + +use strict; +use Getopt::Std; +use FS::UID qw(adminsuidsetup); + +&untaint_argv; #what it sounds like (eww) +#use vars qw($opt_d $opt_v $opt_p $opt_a $opt_s $opt_y); +use vars qw(%opt); +getopts("p:a:d:vsy:", \%opt); + +my $user = shift or die &usage; +adminsuidsetup $user; + +use FS::Cron::bill qw(bill); +bill(%opt, 'freq'=>'1m' ); + +### +# 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-monthly [ -d 'date' ] user [ custnum custnum ... ]\n"; +} + +### +# documentation +### + +=head1 NAME + +freeside-monthly - Run monthly billing and invoice collection events. + +=head1 SYNOPSIS + + freeside-monthly [ -d 'date' ] [ -y days ] [ -p 'payby' ] [ -a agentnum ] [ -s ] [ -v ] user [ custnum custnum ... ] + +=head1 DESCRIPTION + +Bills customers and runs invoice collection events, for the alternate monthly +event chain. If you have defined monthly event checks, should be run from +crontab monthly. + +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. + + -y: In addition to -d, which specifies an absolute date, the -y switch + specifies an offset, in days. For example, "-y 15" would increment the + "pretend date" 15 days from whatever was specified by the -d switch + (or now, if no -d switch was given). + + -p: Only process customers with the specified payby (I<CARD>, I<DCRD>, I<CHEK>, I<DCHK>, I<BILL>, I<COMP>, I<LECB>) + + -a: Only process customers with the specified agentnum + + -s: re-charge setup fees + + -v: enable debugging + +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 NOTE + +In most cases, you would use freeside-daily only and not freeside-monthly. +freeside-monthly would only be used in cases where you have events that can +only be run once each month, for example, batching invoices to a third-party +print/mail provider. + +=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-prepaidd b/FS/bin/freeside-prepaidd index e51a56350..73f7523c4 100644 --- a/FS/bin/freeside-prepaidd +++ b/FS/bin/freeside-prepaidd @@ -3,7 +3,7 @@ use strict; use FS::Daemon qw(daemonize1 drop_root logfile daemonize2 sigint sigterm); use FS::UID qw(adminsuidsetup); -use FS::Record qw(qsearch); # qsearchs); +use FS::Record qw(qsearch qsearchs); use FS::cust_pkg; my $user = shift or die &usage; @@ -37,9 +37,38 @@ while (1) { " AND ( cancel IS NULL OR cancel = 0)" } ) ) { - my $error = $cust_pkg->suspend; - warn "Error suspended package ". $cust_pkg->pkgnum. - " for custnum ". $cust_pkg->custnum. + + my $work_cust_pkg = $cust_pkg; + + my $cust_main = $cust_pkg->cust_main; + if ( $cust_main->total_unapplied_payments > 0 + or $cust_main->total_credited > 0 + ) + { + #this needs a flag to say only do the prepaid packages... + # and only try em if the renewal price matches.. but this will do for now + my $b_error = $cust_main->bill; + if ( $b_error ) { + warn "Error billing customer #". $cust_main->custnum; + next; + } + #$b_error = $cust_main->apply_payments_and_credits; + $b_error = $cust_main->apply_payments; + $b_error = $cust_main->apply_credits; + + $work_cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $work_cust_pkg->pkgnum } ); + + next + if $cust_main->balance <= 0 + and $work_cust_pkg->bill >= time; + } + + my $action = $work_cust_pkg->part_pkg->option('recur_action') || 'suspend'; + + my $error = $work_cust_pkg->$action(); + + warn "Error ${action}ing package ". $work_cust_pkg->pkgnum. + " for custnum ". $work_cust_pkg->custnum. ": $error\n" if $error; } @@ -65,8 +94,8 @@ freeside-prepaidd - Real-time daemon for prepaid packages =head1 DESCRIPTION -Runs continuously and suspendes any prepaid customer packages which have -passed their renewal date (next bill date). +Runs continuously and suspends or cancels any prepaid customer packages which +have passed their renewal date (next bill date). =head1 SEE ALSO diff --git a/FS/bin/freeside-queued b/FS/bin/freeside-queued index 3a0a9b4e5..93d735d1a 100644 --- a/FS/bin/freeside-queued +++ b/FS/bin/freeside-queued @@ -10,11 +10,8 @@ use FS::Record qw(qsearch qsearchs); use FS::queue; use FS::queue_depend; -# no autoloading just yet -use FS::cust_main; -use FS::svc_acct; +# no autoloading for non-FS classes... use Net::SSH 0.07; -use FS::part_export; $DEBUG = 0; @@ -44,7 +41,7 @@ while ( $@ ) { } } -logfile( "/usr/local/etc/freeside/queuelog.". $FS::UID::datasrc ); +logfile( "%%%FREESIDE_LOG%%%/queuelog.". $FS::UID::datasrc ); warn "completing daemonization (detaching))\n" if $DEBUG; daemonize2(); diff --git a/FS/bin/freeside-reset-fixed b/FS/bin/freeside-reset-fixed new file mode 100755 index 000000000..5829d441b --- /dev/null +++ b/FS/bin/freeside-reset-fixed @@ -0,0 +1,69 @@ +#!/usr/bin/perl -w + +use strict; +use vars qw($opt_p $opt_s $opt_r); +use Getopt::Std; +use FS::UID qw(adminsuidsetup); +use FS::Record qw(qsearch qsearchs); +use FS::cust_svc; +use FS::svc_Common; + +getopts('p:s:r'); + +my $user = shift or die &usage; +adminsuidsetup $user; + +die &usage + if ($opt_p && $opt_s); + +$FS::Record::nowarn_identical = 1; +$FS::svc_Common::noexport_hack = 1 + unless $opt_r; + +my @svc_x = (); +if ( $opt_s ) { + $opt_s =~ /^(\d+)$/ or die "invalid svcnum"; + my $cust_svc = qsearchs('cust_svc', { svcnum => $1 } ) + or die "svcnum $opt_s not found\n"; + push @svc_x, $cust_svc->svc_x; +} elsif ( $opt_p ) { + $opt_p =~ /^(\d+)$/ or die "invalid svcpart"; + push @svc_x, map { $_->svc_x } qsearch('cust_svc', { svcpart => $1 } ); + die "no services with svcpart $opt_p found\n" unless @svc_x; +} else { + push @svc_x, map { $_->svc_x } qsearch('cust_svc', {} ); + die "no services found\n" unless @svc_x; +} + +foreach my $svc_x ( @svc_x ) { + my $result = $svc_x->setfixed; + die $result unless ref($result); + my $error = $svc_x->replace + if $svc_x->modified; + die $error if $error; +} + + +sub usage { + die "Usage:\n\n freeside-reset-fixed user [ -s svcnum | -p svcpart ] [ -r ]\n"; +} + +=head1 NAME + +freeside-reset-fixed - Command line tool to set the fixed columns for existing services + +=head1 SYNOPSIS + + freeside-reset-fixed user [ -s svcnum | -p svcpart ] [ -r ] + +=head1 DESCRIPTION + + Resets the fixed columns for the specified service part or service number. + Re-exports the service if -r is specified. + +=head1 SEE ALSO + +L<freeside-reexport>, L<FS::part_svc> + +=cut + diff --git a/FS/bin/freeside-selfservice-server b/FS/bin/freeside-selfservice-server index c73349a60..187bc1469 100644 --- a/FS/bin/freeside-selfservice-server +++ b/FS/bin/freeside-selfservice-server @@ -1,7 +1,8 @@ #!/usr/bin/perl -w use strict; -use vars qw( $Debug %kids $kids $max_kids $ssh_pid $keepalives ); +use vars qw( $FREESIDE_LOG $FREESIDE_LOCK ); +use vars qw( $Debug %kids $kids $max_kids $ssh_pid %old_ssh_pid $keepalives ); use subs qw( lock_write unlock_write myshutdown usage ); use Fcntl qw(:flock); use POSIX qw(:sys_wait_h); @@ -18,6 +19,9 @@ use FS::Conf; use FS::cust_bill; use FS::cust_pkg; +$FREESIDE_LOG = "%%%FREESIDE_LOG%%%"; +$FREESIDE_LOCK = "%%%FREESIDE_LOCK%%%"; + $Debug = 1; # 2 will turn on more logging # 3 will log packet contents, including passwords @@ -29,8 +33,7 @@ my $user = shift or die &usage; my $machine = shift or die &usage; my $tag = scalar(@ARGV) ? shift : ''; -my $lock_file = "/usr/local/etc/freeside/selfservice.$machine.writelock"; - +my $lock_file = "$FREESIDE_LOCK/selfservice.$machine.writelock"; # to keep pid files unique w/multi machines (and installs!) # $FS::UID::datasrc not posible @@ -50,11 +53,10 @@ $ENV{HOME} = (getpwuid($>))[7]; #for ssh adminsuidsetup $user; #logfile("/usr/local/etc/freeside/selfservice.". $FS::UID::datasrc); #MACHINE -logfile("/usr/local/etc/freeside/selfservice.$machine.log"); +logfile("$FREESIDE_LOG/selfservice.$machine.log"); daemonize2(); - my $conf = new FS::Conf; my $clientd = "/usr/local/sbin/freeside-selfservice-clientd"; #better name? @@ -102,6 +104,7 @@ while (1) { if ( $ssh_pid ) { warn "sending TERM signal to ssh process $ssh_pid\n" if $Debug; kill 'TERM', $ssh_pid; + $old_ssh_pid{$ssh_pid} = 1; $ssh_pid = 0; } last; @@ -133,11 +136,11 @@ while (1) { } else { #kid time ##get new db handle - #$FS::UID::dbh->{InactiveDestroy} = 1; - #forksuidsetup($user); + $FS::UID::dbh->{InactiveDestroy} = 1; + forksuidsetup($user); #get db handle - adminsuidsetup($user); + #adminsuidsetup($user); my $type = $packet->{_packet}; warn "calling $type handler\n" if $Debug; @@ -180,6 +183,10 @@ sub reap_kids { delete $kids{$kid}; } } + + foreach my $pid ( keys %old_ssh_pid ) { + waitpid($pid, WNOHANG) and delete $old_ssh_pid{$pid}; + } #warn "done reaping\n"; } diff --git a/FS/bin/freeside-setup b/FS/bin/freeside-setup index a16e51749..ddc210f50 100755 --- a/FS/bin/freeside-setup +++ b/FS/bin/freeside-setup @@ -4,28 +4,27 @@ BEGIN { $FS::Schema::setup_hack = 1; } use strict; -use vars qw($opt_s); +use vars qw($opt_u $opt_d $opt_v); use Getopt::Std; -use Locale::Country; -use Locale::SubCountry; use FS::UID qw(adminsuidsetup datasrc checkeuid getsecrets); +use FS::CurrentUser; use FS::Schema qw( dbdef_dist reload_dbdef ); use FS::Record; -use FS::cust_main_county; #use FS::raddb; -use FS::part_bill_event; +use FS::Setup qw(create_initial_data); die "Not running uid freeside!" unless checkeuid(); #my %attrib2db = # map { lc($FS::raddb::attrib{$_}) => $_ } keys %FS::raddb::attrib; -getopts("s"); -my $user = shift or die &usage; -getsecrets($user); +getopts("u:vd:"); +#my $user = shift or die &usage; + +getsecrets($opt_u); #$user); #needs to match FS::Record -my($dbdef_file) = "/usr/local/etc/freeside/dbdef.". datasrc; +my($dbdef_file) = "%%%FREESIDE_CONF%%%/dbdef.". datasrc; ### @@ -88,12 +87,14 @@ $dbdef->save($dbdef_file); # create 'em ### -my $dbh = adminsuidsetup $user; +$FS::CurrentUser::upgrade_hack = 1; +my $dbh = adminsuidsetup $opt_u; #$user; #create tables $|=1; foreach my $statement ( $dbdef->sql($dbh) ) { + warn $statement if $statement =~ /TABLE cdr/; $dbh->do( $statement ) or die "CREATE error: ". $dbh->errstr. "\ndoing statement: $statement"; } @@ -104,69 +105,14 @@ dbdef_create($dbh, $dbdef_file); delete $FS::Schema::dbdef_cache{$dbdef_file}; #force an actual reload reload_dbdef($dbdef_file); -#cust_main_county -foreach my $country ( sort map uc($_), all_country_codes ) { - - my $subcountry = eval { new Locale::SubCountry($country) }; - my @states = $subcountry ? $subcountry->all_codes : undef; - - if ( !scalar(@states) || ( scalar(@states) == 1 && !defined($states[0]) ) ) { - - my $cust_main_county = new FS::cust_main_county({ - 'tax' => 0, - 'country' => $country, - }); - my $error = $cust_main_county->insert; - die $error if $error; - - } else { - - if ( $states[0] =~ /^(\d+|\w)$/ ) { - @states = map $subcountry->full_name($_), @states - } - - foreach my $state ( @states ) { +create_initial_data('domain' => $opt_d); - my $cust_main_county = new FS::cust_main_county({ - 'state' => $state, - 'tax' => 0, - 'country' => $country, - }); - my $error = $cust_main_county->insert; - die $error if $error; - - } - - } -} - -#billing events -foreach my $aref ( - #[ 'COMP', 'Comp invoice', '$cust_bill->comp();', 30, 'comp' ], - [ 'CARD', 'Batch card', '$cust_bill->batch_card();', 40, 'batch-card' ], - [ 'BILL', 'Send invoice', '$cust_bill->send();', 50, 'send' ], - [ 'DCRD', 'Send invoice', '$cust_bill->send();', 50, 'send' ], - [ 'DCHK', 'Send invoice', '$cust_bill->send();', 50, 'send' ], -) { - - my $part_bill_event = new FS::part_bill_event({ - 'payby' => $aref->[0], - 'event' => $aref->[1], - 'eventcode' => $aref->[2], - 'seconds' => 0, - 'weight' => $aref->[3], - 'plan' => $aref->[4], - }); - my($error); - $error=$part_bill_event->insert; - die $error if $error; - -} +warn "Freeside database initialized - commiting transaction\n" if $opt_v; $dbh->commit or die $dbh->errstr; $dbh->disconnect or die $dbh->errstr; -#print "Freeside database initialized sucessfully\n"; +warn "Database initialization committed successfully\n" if $opt_v; sub dbdef_create { # reverse engineer the schema from the DB and save to file my( $dbh, $file ) = @_; @@ -175,8 +121,10 @@ sub dbdef_create { # reverse engineer the schema from the DB and save to file } sub usage { - die "Usage:\n freeside-setup user\n"; + die "Usage:\n freeside-setup -d domain.name [ -v ]\n" + # [ -u user ] for devel/multi-db installs } 1; + diff --git a/FS/bin/freeside-sqlradius-radacctd b/FS/bin/freeside-sqlradius-radacctd index e98eaa015..83fd4bfd1 100644 --- a/FS/bin/freeside-sqlradius-radacctd +++ b/FS/bin/freeside-sqlradius-radacctd @@ -23,7 +23,7 @@ drop_root(); adminsuidsetup $user; -logfile( "/usr/local/etc/freeside/sqlradius-radacctd-log.". $FS::UID::datasrc ); +logfile( "%%%FREESIDE_LOG%%%/sqlradius-radacctd-log.". $FS::UID::datasrc ); daemonize2(); diff --git a/FS/bin/freeside-upgrade b/FS/bin/freeside-upgrade index 419384c2a..3a4e4f8e3 100755 --- a/FS/bin/freeside-upgrade +++ b/FS/bin/freeside-upgrade @@ -1,88 +1,45 @@ #!/usr/bin/perl -w use strict; +use vars qw($opt_d $opt_q $opt_v); use vars qw($DEBUG $DRY_RUN); -use Term::ReadKey; -use DBIx::DBSchema 0.27; +use Getopt::Std; +use DBIx::DBSchema 0.31; use FS::UID qw(adminsuidsetup checkeuid datasrc ); #getsecrets); +use FS::CurrentUser; use FS::Schema qw( dbdef dbdef_dist reload_dbdef ); +die "Not running uid freeside!" unless checkeuid(); -$DEBUG = 1; -$DRY_RUN = 0; +getopts("dq"); +$DEBUG = !$opt_q; +#$DEBUG = $opt_v; -die "Not running uid freeside!" unless checkeuid(); +$DRY_RUN = $opt_d; my $user = shift or die &usage; +$FS::CurrentUser::upgrade_hack = 1; my $dbh = adminsuidsetup($user); #needs to match FS::Schema... -my $dbdef_file = "/usr/local/etc/freeside/dbdef.". datasrc; +my $dbdef_file = "%%%FREESIDE_CONF%%%/dbdef.". datasrc; dbdef_create($dbh, $dbdef_file); delete $FS::Schema::dbdef_cache{$dbdef_file}; #force an actual reload reload_dbdef($dbdef_file); +$DBIx::DBSchema::DEBUG = $DEBUG; +$DBIx::DBSchema::Table::DEBUG = $DEBUG; -foreach my $table ( dbdef_dist->tables ) { - - if ( dbdef->table($table) ) { - - warn "$table exists\n" if $DEBUG > 1; - - foreach my $column ( dbdef_dist->table($table)->columns ) { - if ( dbdef->table($table)->column($column) ) { - warn " $table.$column exists\n" if $DEBUG > 2; - } else { - - if ( $DEBUG ) { - print STDERR "column $table.$column does not exist. create?"; - next unless yesno(); - } - - foreach my $statement ( - dbdef_dist->table($table)->column($column)->sql_add_column( $dbh ) - ) { - warn "$statement\n" if $DEBUG || $DRY_RUN; - unless ( $DRY_RUN ) { - $dbh->do( $statement) - or die "CREATE error: ". $dbh->errstr. "\nexecuting: $statement"; - } - } - - } - - } - - #should eventually check & create missing indices - - #should eventually drop columns not in dbdef_dist... - - } else { - - if ( $DEBUG ) { - print STDERR "table $table does not exist. create?"; - next unless yesno(); - } - - foreach my $statement ( - dbdef_dist->table($table)->sql_create_table( $dbh ) - ) { - warn "$statement\n" if $DEBUG || $DRY_RUN; - unless ( $DRY_RUN ) { - $dbh->do( $statement) - or die "CREATE error: ". $dbh->errstr. "\nexecuting: $statement"; - } - } - - } - +if ( $DRY_RUN ) { + print join(";\n", dbdef->sql_update_schema( dbdef_dist, $dbh ) ). ";\n"; + exit; +} else { + dbdef->update_schema( dbdef_dist, $dbh ); } -# should eventually drop tables not in dbdef_dist too i guess... - $dbh->commit or die $dbh->errstr; dbdef_create($dbh, $dbdef_file); @@ -91,32 +48,6 @@ $dbh->disconnect or die $dbh->errstr; ### -my $all = 0; -sub yesno { - print STDERR ' [yes/no/all] '; - if ( $all ) { - warn "yes\n"; - return 1; - } else { - while ( 1 ) { - ReadMode 4; - my $x = lc(ReadKey); - ReadMode 0; - if ( $x eq 'n' ) { - warn "no\n"; - return 0; - } elsif ( $x eq 'y' ) { - warn "yes\n"; - return 1; - } elsif ( $x eq 'a' ) { - warn "yes\n"; - $all = 1; - return 1; - } - } - } -} - sub dbdef_create { # reverse engineer the schema from the DB and save to file my( $dbh, $file ) = @_; my $dbdef = new_native DBIx::DBSchema $dbh; @@ -124,8 +55,31 @@ sub dbdef_create { # reverse engineer the schema from the DB and save to file } sub usage { - die "Usage:\n freeside-upgrade user\n"; + die "Usage:\n freeside-upgrade [ -d ] [ -q | -v ] user\n"; } -1; +=head1 NAME + +freeside-upgrade - Upgrades database schema for new freeside verisons. + +=head1 SYNOPSIS + + freeside-adduser [ -d ] [ -q | -v ] + +=head1 DESCRIPTION + +Reads your existing database schema and updates it to match the current schema, +adding any columns or tables necessary. + + [ -d ]: Dry run; output SQL statements (to STDOUT) only, but do not execute + them. + + [ -q ]: Run quietly. This may become the default at some point. + + [ -v ]: Run verbosely, sending debugging information to STDERR. This is the + current default. + +=head1 SEE ALSO + +=cut diff --git a/FS/t/cancel_reason.t b/FS/t/AccessRight.t index a5948f657..a96684224 100644 --- a/FS/t/cancel_reason.t +++ b/FS/t/AccessRight.t @@ -1,5 +1,5 @@ BEGIN { $| = 1; print "1..1\n" } END {print "not ok 1\n" unless $loaded;} -use FS::cancel_reason; +use FS::AccessRight; $loaded=1; print "ok 1\n"; diff --git a/FS/t/ConfDefaults.t b/FS/t/ConfDefaults.t new file mode 100644 index 000000000..433555adb --- /dev/null +++ b/FS/t/ConfDefaults.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::ConfDefaults; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/Cron-backup.t b/FS/t/Cron-backup.t new file mode 100644 index 000000000..847d41aed --- /dev/null +++ b/FS/t/Cron-backup.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::Cron::backup; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/Cron-bill.t b/FS/t/Cron-bill.t new file mode 100644 index 000000000..42c7b4f9e --- /dev/null +++ b/FS/t/Cron-bill.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::Cron::bill; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/Cron-vacuum.t b/FS/t/Cron-vacuum.t new file mode 100644 index 000000000..eaa6b762a --- /dev/null +++ b/FS/t/Cron-vacuum.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::Cron::vacuum; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/access_group.t b/FS/t/access_group.t new file mode 100644 index 000000000..be141099b --- /dev/null +++ b/FS/t/access_group.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::access_group; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/access_groupagent.t b/FS/t/access_groupagent.t new file mode 100644 index 000000000..aff1f2524 --- /dev/null +++ b/FS/t/access_groupagent.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::access_groupagent; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/access_right.t b/FS/t/access_right.t new file mode 100644 index 000000000..66cd362e8 --- /dev/null +++ b/FS/t/access_right.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::access_right; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/access_user.t b/FS/t/access_user.t new file mode 100644 index 000000000..cab679d8d --- /dev/null +++ b/FS/t/access_user.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::access_user; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/access_user_pref.t b/FS/t/access_user_pref.t new file mode 100644 index 000000000..282209830 --- /dev/null +++ b/FS/t/access_user_pref.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::access_user_pref; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/access_usergroup.t b/FS/t/access_usergroup.t new file mode 100644 index 000000000..383a7cf9c --- /dev/null +++ b/FS/t/access_usergroup.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::access_usergroup; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cdr.t b/FS/t/cdr.t new file mode 100644 index 000000000..1d1f3eb4e --- /dev/null +++ b/FS/t/cdr.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cdr; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cdr_calltype.t b/FS/t/cdr_calltype.t new file mode 100644 index 000000000..d4e13943e --- /dev/null +++ b/FS/t/cdr_calltype.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cdr_calltype; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cdr_carrier.t b/FS/t/cdr_carrier.t new file mode 100644 index 000000000..1e2161558 --- /dev/null +++ b/FS/t/cdr_carrier.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cdr_carrier; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cdr_type.t b/FS/t/cdr_type.t new file mode 100644 index 000000000..9dff15a32 --- /dev/null +++ b/FS/t/cdr_type.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cdr_type; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cdr_upstream_rate.t b/FS/t/cdr_upstream_rate.t new file mode 100644 index 000000000..f9458c527 --- /dev/null +++ b/FS/t/cdr_upstream_rate.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cdr_upstream_rate; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_bill_ApplicationCommon.t b/FS/t/cust_bill_ApplicationCommon.t new file mode 100644 index 000000000..fa03d3420 --- /dev/null +++ b/FS/t/cust_bill_ApplicationCommon.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_bill_ApplicationCommon; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_bill_pay_batch.t b/FS/t/cust_bill_pay_batch.t new file mode 100644 index 000000000..bc3a8277c --- /dev/null +++ b/FS/t/cust_bill_pay_batch.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_bill_pay_batch; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_bill_pay_pkg.t b/FS/t/cust_bill_pay_pkg.t new file mode 100644 index 000000000..b8fcddb41 --- /dev/null +++ b/FS/t/cust_bill_pay_pkg.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_bill_pay_pkg; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_credit_bill_pkg.t b/FS/t/cust_credit_bill_pkg.t new file mode 100644 index 000000000..4eb84c327 --- /dev/null +++ b/FS/t/cust_credit_bill_pkg.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_credit_bill_pkg; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_main_note.t b/FS/t/cust_main_note.t new file mode 100644 index 000000000..41a7bac0b --- /dev/null +++ b/FS/t/cust_main_note.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_main_note; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_pkg_reason.t b/FS/t/cust_pkg_reason.t new file mode 100644 index 000000000..2f0a4fa4f --- /dev/null +++ b/FS/t/cust_pkg_reason.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_pkg_reason; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/cust_tax_exempt_pkg.t b/FS/t/cust_tax_exempt_pkg.t new file mode 100644 index 000000000..099a0ce8a --- /dev/null +++ b/FS/t/cust_tax_exempt_pkg.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_tax_exempt_pkg; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/h_cust_bill.t b/FS/t/h_cust_bill.t new file mode 100644 index 000000000..ceccb2a3d --- /dev/null +++ b/FS/t/h_cust_bill.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::h_cust_bill; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/h_cust_tax_exempt.t b/FS/t/h_cust_tax_exempt.t new file mode 100644 index 000000000..432238aa5 --- /dev/null +++ b/FS/t/h_cust_tax_exempt.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::h_cust_tax_exempt; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/inventory_class.t b/FS/t/inventory_class.t new file mode 100644 index 000000000..80b2fa210 --- /dev/null +++ b/FS/t/inventory_class.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::inventory_class; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/inventory_item.t b/FS/t/inventory_item.t new file mode 100644 index 000000000..8ce9d677c --- /dev/null +++ b/FS/t/inventory_item.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::inventory_item; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/part_pkg-voip_cdr.t b/FS/t/part_pkg-voip_cdr.t new file mode 100644 index 000000000..2d988a34f --- /dev/null +++ b/FS/t/part_pkg-voip_cdr.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::part_pkg::voip_cdr; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/pay_batch.t b/FS/t/pay_batch.t new file mode 100644 index 000000000..c43133dc2 --- /dev/null +++ b/FS/t/pay_batch.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::pay_batch; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/payby.t b/FS/t/payby.t new file mode 100644 index 000000000..7430bc8e5 --- /dev/null +++ b/FS/t/payby.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::payby; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/payinfo_Mixin.t b/FS/t/payinfo_Mixin.t new file mode 100644 index 000000000..3567c8e08 --- /dev/null +++ b/FS/t/payinfo_Mixin.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::payinfo_Mixin; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/pkg_class.t b/FS/t/pkg_class.t new file mode 100644 index 000000000..fb3774f8c --- /dev/null +++ b/FS/t/pkg_class.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::pkg_class; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/reason.t b/FS/t/reason.t new file mode 100644 index 000000000..d5e4dc9e7 --- /dev/null +++ b/FS/t/reason.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::reason; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/reason_type.t b/FS/t/reason_type.t new file mode 100644 index 000000000..279d5b950 --- /dev/null +++ b/FS/t/reason_type.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::reason_type; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/registrar.t b/FS/t/registrar.t new file mode 100644 index 000000000..a6ba13437 --- /dev/null +++ b/FS/t/registrar.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::registrar; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/svc_External_Common.t b/FS/t/svc_External_Common.t new file mode 100644 index 000000000..a0b2ea2fd --- /dev/null +++ b/FS/t/svc_External_Common.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::svc_External_Common; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/svc_Parent_Mixin.t b/FS/t/svc_Parent_Mixin.t new file mode 100644 index 000000000..ed9923fc0 --- /dev/null +++ b/FS/t/svc_Parent_Mixin.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::svc_Parent_Mixin; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/svc_phone.t b/FS/t/svc_phone.t new file mode 100644 index 000000000..15b9ca275 --- /dev/null +++ b/FS/t/svc_phone.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::svc_phone; +$loaded=1; +print "ok 1\n"; |