diff options
| author | ivan <ivan> | 2007-08-01 22:26:52 +0000 |
|---|---|---|
| committer | ivan <ivan> | 2007-08-01 22:26:52 +0000 |
| commit | eb4ff7f73c5d4bdf74a3472448b5a195598ff4cd (patch) | |
| tree | bb38241e8c865c3bca861da7749071feeadd2b5b /FS | |
| parent | 32b5d3a31f112a381f0a15ac5e3a2204242f3405 (diff) | |
event refactor, landing on HEAD!
Diffstat (limited to 'FS')
93 files changed, 5745 insertions, 535 deletions
diff --git a/FS/FS/AccessRight.pm b/FS/FS/AccessRight.pm index de3423a..fb7e538 100644 --- a/FS/FS/AccessRight.pm +++ b/FS/FS/AccessRight.pm @@ -12,6 +12,14 @@ FS::AccessRight - Access control rights. use FS::AccessRight; + my @rights = FS::AccessRight->rights; + + #my %rights = FS::AccessRight->rights_categorized; + tie my %rights, 'Tie::IxHash', FS::AccessRight->rights_categorized; + foreach my $category ( keys %rights ) { + my @category_rights = @{ $rights{$category} }; + } + =head1 DESCRIPTION Access control rights - Permission to perform specific actions that can be @@ -75,131 +83,202 @@ assigned to users and/or groups. # ##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', - 'Suspend customer package later', - '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 - 'Edit home dir', #NEW - 'Edit www config', #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; +#well, this is what we have for now. getting better. +tie my %rights, 'Tie::IxHash', + + ### + # basic customer rights + ### + 'Customer rights' => [ + 'New customer', + 'View customer', + #'View Customer | View tickets', + 'Edit customer', + 'Cancel customer', + 'Complimentary customer', #aka users-allow_comp + { rightname=>'Delete customer', desc=>"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 customer's packages if they cancel service." }, #aka. deletecustomers + 'Add customer note', #NEW + 'Edit customer note', #NEW + ], + + ### + # customer package rights + ### + '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', + 'Suspend customer package later', + '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 + ### + 'Customer service rights' => [ + 'Edit usage', #NEW + 'Edit home dir', #NEW + 'Edit www config', #NEW + 'View customer services', #NEW + 'Provision customer service', + 'Recharge customer service', #NEW + 'Unprovision customer service', + + { rightname=>'View/link unlinked services', global=>1 }, #not agent-virtualizable without more work + ], + + ### + # customer invoice/financial info rights + ### + 'Customer invoice / financial info rights' => [ + 'View invoices', + 'View customer tax exemptions', #yow + 'View customer batched payments', #NEW + 'View customer billing events', #NEW + ], + + ### + # customer payment rights + ### + 'Customer payment rights' => [ + 'Post payment', + 'Post payment batch', + { rightname=>'Unapply payment', desc=>'Enable "unapplication" of unclosed payments from specific invoices.' }, #aka. unapplypayments + 'Process payment', + 'Refund payment', + + { rightname=>'Delete payment', desc=>'Enable deletion of unclosed payments. Be very careful! Only delete payments that were data-entry errors, not adjustments.' }, #aka. deletepayments Optionally specify one or more comma-separated email addresses to be notified when a payment is deleted. + + ], + + ### + # customer credit rights + ### + 'Customer credit and refund rights' => [ + 'Post credit', + #'Apply credit', + { rightname=>'Unapply credit', desc=>'Enable "unapplication" of unclosed credits.' }, #aka unapplycredits + { rightname=>'Delete credit', desc=>'Enable deletion of unclosed credits. Be very careful! Only delete credits that were data-entry errors, not adjustments.' }, #aka. deletecredits Optionally specify one or more comma-separated email addresses to be notified when a credit is deleted. + 'Delete refund', #NEW + ], + + ### + # customer voiding rights.. + ### + 'Customer void rights' => [ + { rightname=>'Credit card void', desc=>'Enable local-only voiding of echeck payments in addition to refunds against the payment gateway.' }, #aka. cc-void + { rightname=>'Echeck void', desc=>'Enable local-only voiding of echeck payments in addition to refunds against the payment gateway.' }, #aka. echeck-void + 'Regular void', + { rightname=>'Unvoid', desc=>'Enable unvoiding of voided payments' }, #aka. unvoid + + + ], + + ### + # report/listing rights... + ### + 'Reprting/listing rights' => [ + 'List customers', + 'List zip codes', #NEW + 'List invoices', + 'List packages', + 'List services', + + { rightname=> 'List rating data', desc=>'Usage reports', global=>1 }, + 'Billing event reports', + 'Financial reports', + ], + + ### + # misc rights + ### + 'Miscellaneous rights' => [ + { rightname=>'Job queue', global=>1 }, + { rightname=>'Process batches', global=>1 }, + { rightname=>'Reprocess batches', global=>1 }, + { rightname=>'Import', global=>1 }, #some of these are ag-virt'ed now? give em their own ACLs + { rightname=>'Export', global=>1 }, + #], + # + ### + # misc misc rights + ### + #'Database access rights' => [ + { rightname=>'Raw SQL', global=>1 }, #NEW + ], + + ### + # setup/config rights + ### + 'Configuration rights' => [ + 'Edit advertising sources', + { rightname=>'Edit global advertising sources', global=>1 }, + + 'Edit billing events', + { rightname=>'Edit global billing events', global=>1 }, + + { rightname=>'Configuration', global=>1 }, #most of the rest of the configuraiton is not agent-virtualized + ], + +; + +=head1 CLASS METHODS + +=over 4 + +=item rights + +Returns a list of right names. + +=cut + + sub rights { + #my $class = shift; + map { ref($_) ? $_->{'rightname'} : $_ } map @{ $rights{$_} }, keys %rights; + } + +=item rights_info + +Returns a list of key-value pairs suitable for assigning to a hash. Keys are +category names and values are list references of rights. Each element of the +list reference scalar right name or a hashref with the following keys: + +=over 4 + +=item rightname - Right name + +=item desc - Extended right description + +=item global - Global flag, indicates that this access right provides access to global data which is shared among all agents. + +=back + +=cut + +sub rights_info { + %rights; } +=back + +=head1 BUGS + +Damn those infernal six-legged creatures! + +=head1 SEE ALSO + +L<FS::access_right>, L<FS::access_group>, L<FS::access_user> + +=cut + +1; + diff --git a/FS/FS/Conf.pm b/FS/FS/Conf.pm index f797f27..7f64058 100644 --- a/FS/FS/Conf.pm +++ b/FS/FS/Conf.pm @@ -171,6 +171,30 @@ sub config_orbase { } } +=item invoice_templatenames + +Returns all possible invoice template names. + +=cut + +sub invoice_templatenames { + my( $self ) = @_; + + my %templatenames = (); + foreach my $item ( $self->config_items ) { + foreach my $base ( @base_items ) { + my( $main, $ext) = split(/\./, $base); + $ext = ".$ext" if $ext; + if ( $item->key =~ /^${main}_(.+)$ext$/ ) { + $templatenames{$1}++; + } + } + } + + sort keys %templatenames; + +} + =item touch KEY [ AGENT ]; Creates the specified configuration key if it does not exist. @@ -498,6 +522,21 @@ httemplate/docs/config.html logo.eps ); +@base_items = qw ( + invoice_template + invoice_latex + invoice_latexreturnaddress + invoice_latexfooter + invoice_latexsmallfooter + invoice_latexnotes + invoice_html + invoice_htmlreturnaddress + invoice_htmlfooter + invoice_htmlnotes + logo.png + logo.eps + ); + @config_items = map { new FS::ConfItem $_ } ( { @@ -1912,6 +1951,25 @@ httemplate/docs/config.html }, { + 'key' => 'disable-fuzzy', + 'section' => 'UI', + 'description' => 'Disable fuzzy searching. Speeds up searching for large sites, but only shows exact matches.', + 'type' => 'checkbox', + }, + + { 'key' => 'pkg_referral', + 'section' => '', + 'description' => 'Enable package-specific advertising sources.', + 'type' => 'checkbox', + }, + + { 'key' => 'pkg_referral-multiple', + 'section' => '', + 'description' => 'In addition, allow multiple advertising sources to be associated with a single package.', + 'type' => 'checkbox', + }, + + { 'key' => 'dashboard-toplist', 'section' => 'UI', 'description' => 'List of items to display on the top of the front page', diff --git a/FS/FS/Cron/bill.pm b/FS/FS/Cron/bill.pm index 3ba1b53..1576edc 100644 --- a/FS/FS/Cron/bill.pm +++ b/FS/FS/Cron/bill.pm @@ -6,6 +6,8 @@ use Exporter; use Date::Parse; use FS::Record qw(qsearch qsearchs); use FS::cust_main; +use FS::part_event; +use FS::part_event_condition; @ISA = qw( Exporter ); @EXPORT_OK = qw ( bill ); @@ -14,7 +16,11 @@ sub bill { my %opt = @_; + my $check_freq = $opt{'check_freq'} || '1d'; + $FS::cust_main::DEBUG = 1 if $opt{'v'}; + $FS::cust_main::DEBUG = $opt{'l'} if $opt{'l'}; + #$FS::cust_event::DEBUG = $opt{'l'} if $opt{'l'}; my %search = (); $search{'payby'} = $opt{'p'} if $opt{'p'}; @@ -38,91 +44,76 @@ sub bill { ) ) 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 $where_event = join(' OR ', map { + my $eventtable = $_; + + my $join = FS::part_event_condition->join_conditions_sql( $eventtable ); + my $where = FS::part_event_condition->where_conditions_sql( $eventtable, + 'time'=>$time, + ); + + my $are_part_event = + "0 < ( SELECT COUNT(*) FROM part_event $join + WHERE check_freq = '$check_freq' + AND eventtable = '$eventtable' + AND ( disabled = '' OR disabled IS NULL ) + AND $where + ) + "; + + if ( $eventtable eq 'cust_main' ) { + $are_part_event; + } else { + "0 < ( SELECT COUNT(*) FROM $eventtable + WHERE cust_main.custnum = $eventtable.custnum + AND $are_part_event + ) + "; + } + + } FS::part_event->eventtables); + + my $extra_sql = ( scalar(%search) ? ' AND ' : ' WHERE ' ). + "( $where_pkg OR $where_event )"; + my @cust_main; if ( @ARGV ) { @cust_main = map { qsearchs('cust_main', { custnum => $_, %search } ) } @ARGV } else { - @cust_main = qsearch('cust_main', \%search, '', $extra_sql ); + + warn "searching for customers:\n". + join("\n", map " $_ => ".$search{$_}, keys %search). "\n". + " $extra_sql\n" + if $opt{'v'} || $opt{'l'}; + + @cust_main = qsearch({ + 'table' => 'cust_main', + 'hashref' => \%search, + 'extra_sql' => $extra_sql, + }); + } - ; my($cust_main,%saw); foreach $cust_main ( @cust_main ) { - my $custnum = $cust_main->custnum; - - # $^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 $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 - || $_->adjourn && $_->adjourn <= $^T - ) - && ! $_->susp - } - $cust_main->ncancelled_pkgs - ) { - my $action = $cust_pkg->part_pkg->option('recur_action') || 'suspend'; - my $error = $cust_pkg->$action(); - warn "Error suspending package ". $cust_pkg->pkgnum. - " for custnum $custnum: $error" - if $error; + if ( $opt{'m'} ) { + + die "XXX multi-process mode not yet completed"; + #add job to queue that calls bill_and_collect with options + + } else { + + $cust_main->bill_and_collect( + 'time' => $time, + 'invoice_time' => $invoice_time, + 'check_freq' => $check_freq, + 'resetup' => $opt{'s'}, + ); + } - - my $error = $cust_main->bill( 'time' => $time, - 'invoice_time' => $invoice_time, - 'resetup' => $opt{'s'}, - ); - warn "Error billing, custnum $custnum: $error" if $error; - - $error = $cust_main->apply_payments_and_credits; - warn "Error applying payments and credits, custnum $custnum: $error" - if $error; - - $error = $cust_main->collect( 'invoice_time' => $time, - 'freq' => $opt{'freq'}, - ); - warn "Error collecting, custnum $custnum: $error" if $error; - + } } diff --git a/FS/FS/Cron/expire_user_pref.pm b/FS/FS/Cron/expire_user_pref.pm new file mode 100644 index 0000000..7ab73d2 --- /dev/null +++ b/FS/FS/Cron/expire_user_pref.pm @@ -0,0 +1,17 @@ +package FS::Cron::expire_user_pref; + +use vars qw( @ISA @EXPORT_OK); +use Exporter; +use FS::UID qw(dbh); + +@ISA = qw( Exporter ); +@EXPORT_OK = qw( expire_user_pref ); + +sub expire_user_pref { + my $sql = "DELETE FROM access_user_pref WHERE expiration IS NOT NULL". + " AND expiration < ?"; + my $sth = dbh->prepare($sql) or die dbh->errstr; + $sth->execute(time) or die $sth->errstr; +} + +1; diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index d14762c..f8711d0 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -213,6 +213,7 @@ The preferred usage is to pass a hash reference of named parameters: #these are optional... 'select' => '*', 'extra_sql' => 'AND field ', + 'order_by' => 'ORDER BY something', #'cache_obj' => '', #optional 'addl_from' => 'LEFT JOIN othtable USING ( field )', } @@ -235,13 +236,14 @@ fine in the common case where there are only two parameters: =cut sub qsearch { - my($stable, $record, $select, $extra_sql, $cache, $addl_from ); + my($stable, $record, $select, $extra_sql, $order_by, $cache, $addl_from ); if ( ref($_[0]) ) { #hashref for now, eventually maybe accept a list too my $opt = shift; $stable = $opt->{'table'} or die "table name is required"; $record = $opt->{'hashref'} || {}; $select = $opt->{'select'} || '*'; $extra_sql = $opt->{'extra_sql'} || ''; + $order_by = $opt->{'order_by'} || ''; $cache = $opt->{'cache_obj'} || ''; $addl_from = $opt->{'addl_from'} || ''; } else { @@ -362,6 +364,7 @@ sub qsearch { } $statement .= " $extra_sql" if defined($extra_sql); + $statement .= " $order_by" if defined($order_by); warn "[debug]$me $statement\n" if $DEBUG > 1; my $sth = $dbh->prepare($statement) @@ -2143,7 +2146,7 @@ sub loadRSA { $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default my $conf = new FS::Conf; - if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') { + if ($conf->exists('encryptionmodule') && $conf->config_binary('encryptionmodule') ne '') { $rsa_module = $conf->config('encryptionmodule'); } @@ -2152,13 +2155,13 @@ sub loadRSA { $rsa_loaded++; } # Initialize Encryption - if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') { + if ($conf->exists('encryptionpublickey') && $conf->config_binary('encryptionpublickey') ne '') { my $public_key = join("\n",$conf->config('encryptionpublickey')); $rsa_encrypt = $rsa_module->new_public_key($public_key); } # Intitalize Decryption - if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') { + if ($conf->exists('encryptionprivatekey') && $conf->config_binary('encryptionprivatekey') ne '') { my $private_key = join("\n",$conf->config('encryptionprivatekey')); $rsa_decrypt = $rsa_module->new_private_key($private_key); } diff --git a/FS/FS/Schema.pm b/FS/FS/Schema.pm index cddc520..bcfe907 100644 --- a/FS/FS/Schema.pm +++ b/FS/FS/Schema.pm @@ -265,15 +265,17 @@ sub tables_hashref { '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', '', '', '', '', + 'disabled', 'char', 'NULL', 1, '', '', + 'ticketing_queueid', 'int', 'NULL', '', '', '', + 'invoice_template', 'varchar', 'NULL', $char_d, '', '', + 'username', 'varchar', 'NULL', $char_d, '', '', #deprecated + '_password', 'varchar', 'NULL', $char_d, '', '', #deprecated + 'freq', 'int', 'NULL', '', '', '', #deprecated (never used) + 'prog', @perl_type, '', '', #deprecated (never used) + ], 'primary_key' => 'agentnum', 'unique' => [], @@ -349,6 +351,84 @@ sub tables_hashref { 'index' => [ ['payby'], ['disabled'], ], }, + 'part_event' => { + 'columns' => [ + 'eventpart', 'serial', '', '', '', '', + 'agentnum', 'int', 'NULL', '', '', '', + 'event', 'varchar', '', $char_d, '', '', + 'eventtable', 'varchar', '', $char_d, '', '', + 'check_freq', 'varchar', 'NULL', $char_d, '', '', + 'weight', 'int', '', '', '', '', + 'action', 'varchar', '', $char_d, '', '', + 'disabled', 'char', 'NULL', 1, '', '', + ], + 'primary_key' => 'eventpart', + 'unique' => [], + 'index' => [ ['agentnum'], ['eventtable'], ['check_freq'], ['disabled'], ], + }, + + 'part_event_option' => { + 'columns' => [ + 'optionnum', 'serial', '', '', '', '', + 'eventpart', 'int', '', '', '', '', + 'optionname', 'varchar', '', $char_d, '', '', + 'optionvalue', 'text', 'NULL', '', '', '', + ], + 'primary_key' => 'optionnum', + 'unique' => [], + 'index' => [ [ 'eventpart' ], [ 'optionname' ] ], + }, + + 'part_event_condition' => { + 'columns' => [ + 'eventconditionnum', 'serial', '', '', '', '', + 'eventpart', 'int', '', '', '', '', + 'conditionname', 'varchar', '', $char_d, '', '', + ], + 'primary_key' => 'eventconditionnum', + 'unique' => [], + 'index' => [ [ 'eventpart' ], [ 'conditionname' ] ], + }, + + 'part_event_condition_option' => { + 'columns' => [ + 'optionnum', 'serial', '', '', '', '', + 'eventconditionnum', 'int', '', '', '', '', + 'optionname', 'varchar', '', $char_d, '', '', + 'optionvalue', 'text', 'NULL', '', '', '', + ], + 'primary_key' => 'optionnum', + 'unique' => [], + 'index' => [ [ 'eventconditionnum' ], [ 'optionname' ] ], + }, + + 'part_event_condition_option_option' => { + 'columns' => [ + 'optionoptionnum', 'serial', '', '', '', '', + 'optionnum', 'int', '', '', '', '', + 'optionname', 'varchar', '', $char_d, '', '', + 'optionvalue', 'text', 'NULL', '', '', '', + ], + 'primary_key' => 'optionoptionnum', + 'unique' => [], + 'index' => [ [ 'optionnum' ], [ 'optionname' ] ], + }, + + 'cust_event' => { + 'columns' => [ + 'eventnum', 'serial', '', '', '', '', + 'eventpart', 'int', '', '', '', '', + 'tablenum', 'int', '', '', '', '', + '_date', @date_type, '', '', + 'status', 'varchar', '', $char_d, '', '', + 'statustext', 'text', 'NULL', '', '', '', + ], + 'primary_key' => 'eventnum', + #no... there are retries now #'unique' => [ [ 'eventpart', 'invnum' ] ], + 'unique' => [], + 'index' => [ ['eventpart'], ['tablenum'], ['status'] ], + }, + 'cust_bill_pkg' => { 'columns' => [ 'billpkgnum', 'serial', '', '', '', '', @@ -681,7 +761,10 @@ sub tables_hashref { ], 'primary_key' => 'pkgnum', 'unique' => [], - 'index' => [ ['custnum'], ['pkgpart'] ], + 'index' => [ ['custnum'], ['pkgpart'], + ['setup'], ['last_bill'], ['bill'], ['susp'], ['adjourn'], + ['expire'], ['cancel'] + ], }, 'cust_pkg_option' => { @@ -1731,6 +1814,16 @@ sub tables_hashref { 'index' => [], }, + 'pkg_referral' => { + 'columns' => [ + 'pkgrefnum', 'serial', '', '', '', '', + 'pkgnum', 'int', '', '', '', '', + 'refnum', 'int', '', '', '', '', + ], + 'primary_key' => 'pkgrefnum', + 'unique' => [ [ 'pkgnum', 'refnum' ] ], + 'index' => [ [ 'pkgnum' ], [ 'refnum' ] ], + }, # name type nullability length default local #'new_table' => { diff --git a/FS/FS/Setup.pm b/FS/FS/Setup.pm index 17101a7..55984d4 100644 --- a/FS/FS/Setup.pm +++ b/FS/FS/Setup.pm @@ -161,51 +161,52 @@ sub initial_data { { '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', - #}, - ], +#XXX need default new-style billing events +# #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 diff --git a/FS/FS/access_group.pm b/FS/FS/access_group.pm index 2519040..b5b693a 100644 --- a/FS/FS/access_group.pm +++ b/FS/FS/access_group.pm @@ -140,7 +140,7 @@ test if this group has the given RIGHTNAME. =cut sub access_right { - my( $self, $name ) = shift; + my( $self, $name ) = @_; qsearchs('access_right', { 'righttype' => 'FS::access_group', 'rightobjnum' => $self->groupnum, 'rightname' => $name, diff --git a/FS/FS/access_user.pm b/FS/FS/access_user.pm index cb43b37..8e4ad46 100644 --- a/FS/FS/access_user.pm +++ b/FS/FS/access_user.pm @@ -308,22 +308,34 @@ Returns a hashref of agentnums this user can view. sub agentnums_href { my $self = shift; - { map { $_ => 1 } $self->agentnums }; + scalar( { map { $_ => 1 } $self->agentnums } ); } -=item agentnums_sql +=item agentnums_sql [ HASHREF | OPTION => VALUE ... ] Returns an sql fragement to select only agentnums this user can view. +Options are passed as a hashref or a list. Available options are: + +=over 4 + +=item null - The frament will also allow the selection of null agentnums. + +=item null_right - The fragment will also allow the selection of null agentnums if the current user has the provided access right + +=back + =cut sub agentnums_sql { - my $self = shift; + my( $self ) = shift; + my %opt = ref($_[0]) ? %{$_[0]} : @_; my @agentnums = map { "agentnum = $_" } $self->agentnums; push @agentnums, 'agentnum IS NULL' - if $self->access_right('View/link unlinked services'); + if $opt{'null'} + || ( $opt{'null_right'} && $self->access_right($opt{'null_right'}) ); return ' 1 = 0 ' unless scalar(@agentnums); '( '. join( ' OR ', @agentnums ). ' )'; diff --git a/FS/FS/access_user_pref.pm b/FS/FS/access_user_pref.pm index ff957f2..31cd4b3 100644 --- a/FS/FS/access_user_pref.pm +++ b/FS/FS/access_user_pref.pm @@ -27,19 +27,22 @@ FS::access_user_pref - Object methods for access_user_pref records =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: +An FS::access_user_pref object represents an per-user preference. Preferenaces +are also used to store transient state information (server-side "cookies"). +FS::access_user_pref inherits from FS::Record. The following fields are +currently supported: =over 4 =item prefnum - primary key -=item usernum - +=item usernum - Internal access user (see L<FS::access_user>) =item prefname - =item prefvalue - +=item expiration - =back @@ -49,7 +52,7 @@ 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 preference. 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. @@ -88,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 preference. If there is an error, returns the error, otherwise returns false. Called by the insert and replace methods. @@ -104,7 +107,8 @@ sub check { $self->ut_numbern('prefnum') || $self->ut_number('usernum') || $self->ut_text('prefname') - || $self->ut_textn('prefvalue') + #|| $self->ut_textn('prefvalue') + || $self->ut_anything('prefvalue') ; return $error if $error; @@ -115,11 +119,9 @@ sub check { =head1 BUGS -The author forgot to customize this manpage. - =head1 SEE ALSO -L<FS::Record>, schema.html from the base documentation. +L<FS::access_user>, L<FS::Record>, schema.html from the base documentation. =cut diff --git a/FS/FS/agent.pm b/FS/FS/agent.pm index e40ef09..57cc945 100644 --- a/FS/FS/agent.pm +++ b/FS/FS/agent.pm @@ -117,6 +117,7 @@ sub check { || $self->ut_number('typenum') || $self->ut_numbern('freq') || $self->ut_textn('prog') + || $self->ut_textn('invoice_template') ; return $error if $error; diff --git a/FS/FS/cust_bill.pm b/FS/FS/cust_bill.pm index 82023f6..f6dbc3d 100644 --- a/FS/FS/cust_bill.pm +++ b/FS/FS/cust_bill.pm @@ -24,6 +24,7 @@ use FS::cust_credit_bill; use FS::pay_batch; use FS::cust_pay_batch; use FS::cust_bill_event; +use FS::cust_event; use FS::part_pkg; use FS::cust_bill_pay; use FS::cust_bill_pay_batch; @@ -271,8 +272,7 @@ sub open_cust_bill_pkg { =item cust_bill_event -Returns the completed invoice events (see L<FS::cust_bill_event>) for this -invoice. +Returns the completed invoice events (deprecated, old-style events - see L<FS::cust_bill_event>) for this invoice. =cut @@ -281,6 +281,54 @@ sub cust_bill_event { qsearch( 'cust_bill_event', { 'invnum' => $self->invnum } ); } +=item num_cust_bill_event + +Returns the number of completed invoice events (deprecated, old-style events - see L<FS::cust_bill_event>) for this invoice. + +=cut + +sub num_cust_bill_event { + my $self = shift; + my $sql = + "SELECT COUNT(*) FROM cust_bill_event WHERE invnum = ?"; + my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql"; + $sth->execute($self->invnum) or die $sth->errstr. " executing $sql"; + $sth->fetchrow_arrayref->[0]; +} + +=item cust_event + +Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice. + +=cut + +#false laziness w/cust_pkg.pm +sub cust_event { + my $self = shift; + qsearch({ + 'table' => 'cust_event', + 'addl_from' => 'JOIN part_event USING ( eventpart )', + 'hashref' => { 'tablenum' => $self->invnum }, + 'extra_sql' => " AND eventtable = 'cust_bill' ", + }); +} + +=item num_cust_event + +Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice. + +=cut + +#false laziness w/cust_pkg.pm +sub num_cust_event { + my $self = shift; + my $sql = + "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ". + " WHERE tablenum = ? AND eventtable = 'cust_bill'"; + my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql"; + $sth->execute($self->invnum) or die $sth->errstr. " executing $sql"; + $sth->fetchrow_arrayref->[0]; +} =item cust_main @@ -2577,6 +2625,8 @@ sub _items_payments { =back + + =head1 SUBROUTINES =over 4 @@ -2698,6 +2748,34 @@ sub re_X { =back +=head1 CLASS METHODS + +=over 4 + +=item owed_sql + +Returns an SQL fragment to retreived the amount owed. + +=cut + +sub owed_sql { + #my $class = shift; + + "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 + ) + "; + +} + =head1 BUGS The delete method. diff --git a/FS/FS/cust_credit.pm b/FS/FS/cust_credit.pm index 84ca79d..e07461d 100644 --- a/FS/FS/cust_credit.pm +++ b/FS/FS/cust_credit.pm @@ -333,10 +333,43 @@ sub cust_main { =back +=head1 CLASS METHODS + +=over 4 + +=item credited_sql + +Returns an SQL fragment to retreive the unapplied amount. + +=cut + +sub credited_sql { + #my $class = shift; + + "amount + - COALESCE( + ( SELECT SUM(amount) FROM cust_credit_refund + WHERE cust_credit.crednum = cust_credit_refund.crednum ) + ,0 + ) + - COALESCE( + ( SELECT SUM(amount) FROM cust_credit_bill + WHERE cust_credit.crednum = cust_credit_bill.crednum ) + ,0 + ) + "; + +} + +=back + =head1 BUGS The delete method. The replace method. +B<credited> and B<credited_sql> should probably be called B<unapplied> and +B<unapplied_sql>. + =head1 SEE ALSO L<FS::Record>, L<FS::cust_credit_refund>, L<FS::cust_refund>, diff --git a/FS/FS/cust_event.pm b/FS/FS/cust_event.pm new file mode 100644 index 0000000..bebd72a --- /dev/null +++ b/FS/FS/cust_event.pm @@ -0,0 +1,407 @@ +package FS::cust_event; + +use strict; +use vars qw( @ISA $DEBUG ); +use Carp qw( croak confess ); +use FS::Record qw( qsearch qsearchs dbdef ); +use FS::cust_main_Mixin; +use FS::part_event; +#for cust_X +use FS::cust_main; +use FS::cust_pkg; +use FS::cust_bill; + +@ISA = qw(FS::cust_main_Mixin FS::Record); + +$DEBUG = 0; + +=head1 NAME + +FS::cust_event - Object methods for cust_event records + +=head1 SYNOPSIS + + use FS::cust_event; + + $record = new FS::cust_event \%hash; + $record = new FS::cust_event { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::cust_event object represents an completed event. FS::cust_event +inherits from FS::Record. The following fields are currently supported: + +=over 4 + +=item eventnum - primary key + +=item eventpart - event definition (see L<FS::part_event>) + +=item tablenum - customer, package or invoice, depending on the value of part_event.eventtable (see L<FS::cust_main>, L<FS::cust_pkg>, and L<FS::cust_bill>) + +=item _date - specified as a UNIX timestamp; see L<perlfunc/"time">. Also see +L<Time::Local> and L<Date::Parse> for conversion functions. + +=item status - event status: B<new>, B<locked>, B<done> or B<failed>. Note: B<done> indicates the event is complete and should not be retried (statustext may still be set to an optional message), while B<failed> indicates the event failed and should be retried. + +=item statustext - additional status detail (i.e. error or progress message) + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new completed invoice event. To add the compelted invoice event to +the database, see L<"insert">. + +Note that this stores the hash reference, not a distinct copy of the hash it +points to. You can ask the object for a copy with the I<hash> method. + +=cut + +# the new method can be inherited from FS::Record, if a table method is defined + +sub table { 'cust_event'; } + +sub cust_linked { $_[0]->cust_main_custnum; } +sub cust_unlinked_msg { + my $self = shift; + "WARNING: can't find cust_main.custnum ". $self->custnum; + #' (cust_bill.invnum '. $self->invnum. ')'; +} +sub custnum { + my $self = shift; + $self->cust_main_custnum(@_) || $self->SUPER::custnum(@_); +} + +=item insert + +Adds this record to the database. If there is an error, returns the error, +otherwise returns false. + +=cut + +# the insert method can be inherited from FS::Record + +=item delete + +Delete this record from the database. + +=cut + +# the delete method can be inherited from FS::Record + +=item replace OLD_RECORD + +Replaces the OLD_RECORD with this one in the database. If there is an error, +returns the error, otherwise returns false. + +=cut + +# the replace method can be inherited from FS::Record + +=item check + +Checks all fields to make sure this is a valid completed invoice event. If +there is an error, returns the error, otherwise returns false. Called by the +insert and replace methods. + +=cut + +# the check method should currently be supplied - FS::Record contains some +# data checking routines + +sub check { + my $self = shift; + + my $error = $self->ut_numbern('eventnum') + || $self->ut_foreign_key('eventpart', 'part_event', 'eventpart') + ; + return $error if $error; + + my $eventtable = $self->part_event->eventtable; + my $dbdef_eventtable = dbdef->table( $eventtable ); + + $error = + $self->ut_foreign_key( 'tablenum', + $eventtable, + $dbdef_eventtable->primary_key + ) + || $self->ut_number('_date') + || $self->ut_enum('status', [qw( new locked done failed )]) + || $self->ut_textn('statustext') + ; + return $error if $error; + + $self->SUPER::check; +} + +=item part_event + +Returns the event definition (see L<FS::part_event>) for this completed event. + +=cut + +sub part_event { + my $self = shift; + qsearchs( 'part_event', { 'eventpart' => $self->eventpart } ); +} + +=item cust_X + +Returns the customer, package, invoice or batched payment (see +L<FS::cust_main>, L<FS::cust_pkg>, L<FS::cust_bill> or L<FS::cust_pay_batch>) +for this completed invoice event. + +=cut + +sub cust_bill { + croak "FS::cust_event::cust_bill called"; +} + +sub cust_X { + my $self = shift; + my $eventtable = $self->part_event->eventtable; + my $dbdef_table = dbdef->table( $eventtable ); + my $primary_key = $dbdef_table->primary_key; + qsearchs( $eventtable, { $primary_key => $self->tablenum } ); +} + +=item test_conditions [ OPTION => VALUE ... ] + +Tests conditions for this event, returns true if all conditions are satisfied, +false otherwise. + +=cut + +sub test_conditions { + my( $self, %opt ) = @_; + my $part_event = $self->part_event; + my $object = $self->cust_X; + my @conditions = $part_event->part_event_condition; + + #no unsatisfied conditions + #! grep ! $_->condition( $object, %opt ), @conditions; + my @unsatisfied = grep ! $_->condition( $object, %opt ), @conditions; + + if ( $opt{'stats_hashref'} ) { + foreach my $unsat (@unsatisfied) { + $opt{'stats_hashref'}->{$unsat->conditionname}++; + } + } + + ! @unsatisfied; +} + +=item do_event + +Runs the event action. + +=cut + +sub do_event { + my $self = shift; + + my $part_event = $self->part_event; + + my $object = $self->cust_X; + my $obj_pkey = $object->primary_key; + my $for = "for ". $object->table. " ". $object->$obj_pkey(); + warn "running cust_event ". $self->eventnum. + " (". $part_event->action. ") $for\n" + if $DEBUG; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + + my $error; + { + local $SIG{__DIE__}; # don't want Mason __DIE__ handler active + $error = eval { $part_event->do_action($object); }; + } + + my $status = ''; + my $statustext = ''; + if ( $@ ) { + $status = 'failed'; + #$statustext = $@; + $statustext = "Error running ". $part_event->action. " action: $@"; + } elsif ( $error ) { + $status = 'done'; + $statustext = $error; + } else { + $status = 'done'; + } + + #replace or add myself + $self->_date(time); + $self->status($status); + $self->statustext($statustext); + + $error = $self->eventnum ? $self->replace : $self->insert; + if ( $error ) { + #this is why we need that locked state... + my $e = 'WARNING: Event run but database not updated - '. + 'error replacing or inserting cust_event '. $self->eventnum. + " $for: $error\n"; + warn $e; + return $e; + } + + ''; + +} + +=item retry + +Changes the status of this event from B<done> to B<failed>, allowing it to be +retried. + +=cut + +sub retry { + my $self = shift; + return '' unless $self->status eq 'done'; + my $old = ref($self)->new( { $self->hash } ); + $self->status('failed'); + $self->replace($old); +} + +#=item retryable +# +#Changes the statustext of this event to B<retriable>, rendering it +#retriable (should retry be called). +# +#=cut + +sub retriable { + confess "cust_event->retriable called"; + 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 + +=over 4 + +=item reprint + +=cut + +sub process_reprint { + process_re_X('print', @_); +} + +=item reemail + +=cut + +sub process_reemail { + process_re_X('email', @_); +} + +=item refax + +=cut + +sub process_refax { + process_re_X('fax', @_); +} + +use Storable qw(thaw); +use Data::Dumper; +use MIME::Base64; +sub process_re_X { + my( $method, $job ) = ( shift, shift ); + + my $param = thaw(decode_base64(shift)); + warn Dumper($param) if $DEBUG; + + re_X( + $method, + $param->{'beginning'}, + $param->{'ending'}, + $param->{'failed'}, + $job, + ); + +} + +sub re_X { + my($method, $beginning, $ending, $failed, $job) = @_; + + my $from = 'LEFT JOIN part_event USING ( eventpart )'; + + # yuck! hardcoed *AND* sequential scans! + my $where = " WHERE action LIKE 'cust_bill_send%'". + " AND cust_event._date >= $beginning". + " AND cust_event._date <= $ending"; + $where .= " AND statustext != '' AND statustext IS NOT NULL" + if $failed; + + my @cust_event = qsearch({ + 'table' => 'cust_event', + 'addl_from' => $from, + 'hashref' => {}, + 'extra_sql' => $where, + }); + + my( $num, $last, $min_sec ) = (0, time, 5); #progresbar foo + foreach my $cust_event ( @cust_event ) { + + # XXX + $cust_event->cust_bill->$method( + $cust_event->part_event->templatename + || $cust_event->cust_main->agent_template + ); + + if ( $job ) { #progressbar foo + $num++; + if ( time - $min_sec > $last ) { + my $error = $job->update_statustext( + int( 100 * $num / scalar(@cust_event) ) + ); + die $error if $error; + $last = time; + } + } + + } + + #this doesn't work, but it would be nice + #if ( $job ) { #progressbar foo + # my $error = $job->update_statustext( + # scalar(@cust_event). " invoices re-${method}ed" + # ); + # die $error if $error; + #} + +} + +=back + +=head1 SEE ALSO + +L<FS::part_event>, L<FS::cust_bill>, L<FS::Record>, schema.html from the +base documentation. + +=cut + +1; + diff --git a/FS/FS/cust_main.pm b/FS/FS/cust_main.pm index 7238e97..fb64fa3 100644 --- a/FS/FS/cust_main.pm +++ b/FS/FS/cust_main.pm @@ -1,5 +1,6 @@ package FS::cust_main; +require 5.006; use strict; use vars qw( @ISA @EXPORT_OK $DEBUG $me $conf @encrypted_fields $import $skip_fuzzyfiles $ignore_expired_card @paytypes); @@ -7,13 +8,9 @@ use vars qw( $realtime_bop_decline_quiet ); #ugh use Safe; use Carp; use Exporter; -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 timelocal_nocheck);"; - eval "use Time::Local qw(timelocal_nocheck);"; -} +use Time::Local qw(timelocal_nocheck); +use Data::Dumper; +use Tie::IxHash; use Digest::MD5 qw(md5_base64); use Date::Format; use Date::Parse; @@ -32,6 +29,7 @@ use FS::cust_bill; use FS::cust_bill_pkg; use FS::cust_pay; use FS::cust_pay_void; +use FS::cust_pay_batch; use FS::cust_credit; use FS::cust_refund; use FS::part_referral; @@ -43,8 +41,9 @@ use FS::cust_bill_pay; use FS::prepay_credit; use FS::queue; use FS::part_pkg; -use FS::part_bill_event qw(due_events); -use FS::cust_bill_event; +use FS::part_event; +use FS::part_event_condition; +#use FS::cust_event; use FS::cust_tax_exempt; use FS::cust_tax_exempt_pkg; use FS::type_pkgs; @@ -1423,11 +1422,10 @@ sub check { $payinfo =~ s/[^\d\@]//g; 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"; } + $payinfo = "$1\@$2"; $self->payinfo($payinfo); $self->paycvv(''); @@ -1547,6 +1545,16 @@ sub all_pkgs { sort sort_packages @cust_pkg; } +=item cust_pkg + +Synonym for B<all_pkgs>. + +=cut + +sub cust_pkg { + shift->all_pkgs(@_); +} + =item ncancelled_pkgs Returns all non-cancelled packages (see L<FS::cust_pkg>) for this customer. @@ -1561,11 +1569,18 @@ sub ncancelled_pkgs { my @cust_pkg = (); if ( $self->{'_pkgnum'} ) { + warn "$me ncancelled_pkgs: returning cached objects" + if $DEBUG > 1; + @cust_pkg = grep { ! $_->getfield('cancel') } values %{ $self->{'_pkgnum'}->cache }; } else { + warn "$me ncancelled_pkgs: searching for packages for custnum ". + $self->custnum + if $DEBUG > 1; + @cust_pkg = qsearch( 'cust_pkg', { 'custnum' => $self->custnum, @@ -1683,10 +1698,20 @@ sub suspend { grep { $_->suspend(@_) } $self->unsuspended_pkgs; } -=item suspend_if_pkgpart PKGPART [ , PKGPART ... ] +=item suspend_if_pkgpart HASHREF | PKGPART [ , PKGPART ... ] Suspends all unsuspended packages (see L<FS::cust_pkg>) matching the listed -PKGPARTs (see L<FS::part_pkg>). +PKGPARTs (see L<FS::part_pkg>). Preferred usage is to pass a hashref instead +of a list of pkgparts; the hashref has the following keys: + +=over 4 + +=item pkgparts - listref of pkgparts + +=item (other options are passed to the suspend method) + +=back + Returns a list: an empty list on success or a list of errors. @@ -1706,10 +1731,19 @@ sub suspend_if_pkgpart { $self->unsuspended_pkgs; } -=item suspend_unless_pkgpart PKGPART [ , PKGPART ... ] +=item suspend_unless_pkgpart HASHREF | PKGPART [ , PKGPART ... ] Suspends all unsuspended packages (see L<FS::cust_pkg>) unless they match the -listed PKGPARTs (see L<FS::part_pkg>). +given PKGPARTs (see L<FS::part_pkg>). Preferred usage is to pass a hashref +instead of a list of pkgparts; the hashref has the following keys: + +=over 4 + +=item pkgparts - listref of pkgparts + +=item (other options are passed to the suspend method) + +=back Returns a list: an empty list on success or a list of errors. @@ -1733,22 +1767,31 @@ sub suspend_unless_pkgpart { Cancels all uncancelled packages (see L<FS::cust_pkg>) for this customer. -Available options are: I<quiet>, I<reasonnum>, and I<ban> +Available options are: -I<quiet> can be set true to supress email cancellation notices. +=over 4 -# I<reasonnum> can be set to a cancellation reason (see L<FS::cancel_reason>) +=item quiet - can be set true to supress email cancellation notices. -I<ban> can be set true to ban this customer's credit card or ACH information, -if present. +=item reason - can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason. The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason. + +=item ban - can be set true to ban this customer's credit card or ACH information, if present. + +=back Always returns a list: an empty list on success or a list of errors. =cut sub cancel { - my $self = shift; - my %opt = @_; + my( $self, %opt ) = @_; + + warn "$me cancel called on customer ". $self->custnum. " with options ". + join(', ', map { "$_: $opt{$_}" } keys %opt ). "\n" + if $DEBUG; + + return ( 'access denied' ) + unless $FS::CurrentUser::CurrentUser->access_right('Cancel customer'); if ( $opt{'ban'} && $self->payby =~ /^(CARD|DCRD|CHEK|DCHK)$/ ) { @@ -1763,7 +1806,13 @@ sub cancel { } - grep { $_ } map { $_->cancel(@_) } $self->ncancelled_pkgs; + my @pkgs = $self->ncancelled_pkgs; + + warn "$me cancelling ". scalar($self->ncancelled_pkgs). "/". + scalar(@pkgs). " packages for customer ". $self->custnum. "\n" + if $DEBUG; + + grep { $_ } map { $_->cancel(%opt) } $self->ncancelled_pkgs; } sub _banned_pay_hashref { @@ -1810,10 +1859,87 @@ sub agent { qsearchs( 'agent', { 'agentnum' => $self->agentnum } ); } +=item bill_and_collect + +Cancels and suspends any packages due, generates bills, applies payments and +cred + +Warns on errors (Does not currently: If there is an error, returns the error, otherwise returns false.) + +Options are passed as name-value pairs. Currently available options are: + +=over 4 + +=item time - bills the customer as if it were that time. Specified as a UNIX timestamp; see L<perlfunc/"time">). Also see L<Time::Local> and L<Date::Parse> for conversion functions. For example: + + use Date::Parse; + ... + $cust_main->bill( 'time' => str2time('April 20th, 2001') ); + +=item invoice_time - used in conjunction with the I<time> option, this option specifies the date of for the generated invoices. Other calculations, such as whether or not to generate the invoice in the first place, are not affected. + +=item check_freq - "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq) + +=item resetup - if set true, re-charges setup fees. + +=back + +=cut + +sub bill_and_collect { + my( $self, %options ) = @_; + + ### + # cancel packages + ### + + #$^T not $options{time} because freeside-daily -d is for pre-printing invoices + foreach my $cust_pkg ( + grep { $_->expire && $_->expire <= $^T } $self->ncancelled_pkgs + ) { + my $error = $cust_pkg->cancel; + warn "Error cancelling expired pkg ". $cust_pkg->pkgnum. + " for custnum ". $self->custnum. ": $error" + if $error; + } + + ### + # suspend packages + ### + + #$^T not $options{time} because freeside-daily -d is for pre-printing invoices + foreach my $cust_pkg ( + grep { ( $_->part_pkg->is_prepaid && $_->bill && $_->bill < $^T + || $_->adjourn && $_->adjourn <= $^T + ) + && ! $_->susp + } + $self->ncancelled_pkgs + ) { + my $error = $cust_pkg->suspend; + warn "Error suspending package ". $cust_pkg->pkgnum. + " for custnum ". $self->custnum. ": $error" + if $error; + } + + ### + # bill and collect + ### + + my $error = $self->bill( %options ); + warn "Error billing, custnum ". $self->custnum. ": $error" if $error; + + $self->apply_payments_and_credits; + + $error = $self->collect( %options ); + warn "Error collecting, custnum". $self->custnum. ": $error" if $error; + +} + =item bill OPTIONS Generates invoices (see L<FS::cust_bill>) for this customer. Usually used in -conjunction with the collect method. +conjunction with the collect method by calling B<bill_and_collect>. If there is an error, returns the error, otherwise returns false. @@ -1829,6 +1955,10 @@ Options are passed as name-value pairs. Currently available options are: ... $cust_main->bill( 'time' => str2time('April 20th, 2001') ); +=item pkg_list - An array ref of specific packages (objects) to attempt billing, instead trying all of them. + + $cust_main->bill( pkg_list => [$pkg1, $pkg2] ); + =item invoice_time - used in conjunction with the I<time> option, this option specifies the date of for the generated invoices. Other calculations, such as whether or not to generate the invoice in the first place, are not affected. =back @@ -1940,6 +2070,13 @@ sub bill { ( $cust_pkg->getfield('bill') || 0 ) <= $time ) { + # XXX should this be a package event? probably. events are called + # at collection time at the moment, though... + if ( $part_pkg->can('reset_usage') ) { + warn " resetting usage counters" if $DEBUG > 1; + $part_pkg->reset_usage($cust_pkg); + } + warn " bill recur\n" if $DEBUG > 1; # XXX shared with $recur_prog @@ -2190,6 +2327,18 @@ sub bill { unless ( $cust_bill->cust_bill_pkg ) { $cust_bill->delete; #don't create an invoice w/o line items + + # XXX this seems to be broken + #( DBD::Pg::st execute failed: ERROR: syntax error at or near "hcb" ) +# # get rid of our fake history too, waste of unecessary space +# my $h_cleanup_query = q{ +# DELETE FROM h_cust_bill hcb +# WHERE hcb.invnum = ? +# AND NOT EXISTS ( SELECT 1 FROM cust_bill cb where cb.invnum = hcb.invnum ) +# }; +# my $h_sth = $dbh->prepare($h_cleanup_query); +# $h_sth->execute($invnum); + $dbh->commit or die $dbh->errstr if $oldAutoCommit; return ''; } @@ -2244,12 +2393,9 @@ sub bill { (Attempt to) collect money for this customer's outstanding invoices (see L<FS::cust_bill>). Usually used after the bill method. -Depending on the value of `payby', this may print or email an invoice (I<BILL>, -I<DCRD>, or I<DCHK>), charge a credit card (I<CARD>), charge via electronic -check/ACH (I<CHEK>), or just add any necessary (pseudo-)payment (I<COMP>). - -Most actions are now triggered by invoice events; see L<FS::part_bill_event> -and the invoice events web interface. +Actions are now triggered by billing events; see L<FS::part_event> and the +billing events web interface. Old-style invoice events (see +L<FS::part_bill_event>) have been deprecated. If there is an error, returns the error, otherwise returns false. @@ -2257,19 +2403,17 @@ Options are passed as name-value pairs. Currently available options are: -invoice_time - Use this time when deciding when to print invoices and -late notices on those invoices. The default is now. It is specified as a UNIX timestamp; see L<perlfunc/"time">). Also see L<Time::Local> and L<Date::Parse> -for conversion functions. +=over 4 + +=item invoice_time - Use this time when deciding when to print invoices and late notices on those invoices. The default is now. It is specified as a UNIX timestamp; see L<perlfunc/"time">). Also see L<Time::Local> and L<Date::Parse> for conversion functions. -retry - Retry card/echeck/LEC transactions even when not scheduled by invoice -events. +=item retry - Retry card/echeck/LEC transactions even when not scheduled by invoice events. -quiet - set true to surpress email card/ACH decline notices. +=item quiet - set true to surpress email card/ACH decline notices. -freq - "1d" for the traditional, daily events (the default), or "1m" for the -new monthly events +=item check_freq - "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq) -payby - allows for one time override of normal customer billing method +=item payby - allows for one time override of normal customer billing method =cut @@ -2291,12 +2435,9 @@ sub collect { $self->select_for_update; #mutex - my $balance = $self->balance; - warn "$me collect customer ". $self->custnum. ": balance $balance\n" - if $DEBUG; - unless ( $balance > 0 ) { #redundant????? - $dbh->rollback if $oldAutoCommit; #hmm - return ''; + if ( $DEBUG ) { + my $balance = $self->balance; + warn "$me collect customer ". $self->custnum. ": balance $balance\n" } if ( exists($options{'retry_card'}) ) { @@ -2311,51 +2452,233 @@ 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 - #next if qsearchs( 'cust_pay_batch', { 'invnum' => $cust_bill->invnum } ); + # false laziness w/pay_batch::import_results - last if $self->balance <= 0; - - warn " invnum ". $cust_bill->invnum. " (owed ". $cust_bill->owed. ")\n" - if $DEBUG > 1; + my $due_cust_event = $self->due_cust_event( + 'time' => $invoice_time, + 'check_freq' => $options{'check_freq'}, + ); + unless( ref($due_cust_event) ) { + $dbh->rollback if $oldAutoCommit; + return $due_cust_event; + } - foreach my $part_bill_event ( due_events ( $cust_bill, - exists($options{'payby'}) - ? $options{'payby'} - : $self->payby, - $invoice_time, - $extra_sql ) ) { + foreach my $cust_event ( @$due_cust_event ) { - last if $cust_bill->owed <= 0 # don't run subsequent events if owed<=0 - || $self->balance <= 0; # or if balance<=0 + #XXX lock event + + #re-eval event conditions (a previous event could have changed things) + next unless $cust_event->test_conditions( 'time' => $invoice_time ); - { - local $realtime_bop_decline_quiet = 1 if $options{'quiet'}; - warn " do_event " . $cust_bill . " ". (%options) . "\n" - if $DEBUG > 1; + { + local $realtime_bop_decline_quiet = 1 if $options{'quiet'}; + warn " running cust_event ". $cust_event->eventnum. "\n" + if $DEBUG > 1; - if (my $error = $part_bill_event->do_event($cust_bill, %options)) { + + #if ( my $error = $cust_event->do_event(%options) ) { #XXX %options? + if ( my $error = $cust_event->do_event() ) { + #XXX wtf is this? figure out a proper dealio with return value + #from do_event # gah, even with transactions. $dbh->commit if $oldAutoCommit; #well. return $error; } + } + + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; + +} + +=item due_cust_event [ HASHREF | OPTION => VALUE ... ] + +Inserts database records for and returns an ordered listref of new events due +for this customer, as FS::cust_event objects (see L<FS::cust_event>). If no +events are due, an empty listref is returned. If there is an error, returns a +scalar error message. + +To actually run the events, call each event's test_condition method, and if +still true, call the event's do_event method. + +Options are passed as a hashref or as a list of name-value pairs. Available +options are: + +=over 4 + +=item check_freq - Search only for events of this check frequency (how often events of this type are checked); currently "1d" (daily, the default) and "1m" (monthly) are recognized. + +=item time - "Current time" for the events. + +=item debug - Debugging level. Default is 0 (no debugging), or can be set to 1 (passed-in options), 2 (traces progress), or 3 (more information) + +=item eventtable - Only return events for the specified eventtable (by default, events of all eventtables are returned) + +=item objects - Explicitly pass the objects to be tested (typically used with eventtable). + +=back + +=cut + +sub due_cust_event { + my $self = shift; + my %opt = ref($_[0]) ? %{ $_[0] } : @_; + + #??? + #my $DEBUG = $opt{'debug'} + local($DEBUG) = $opt{'debug'} + if defined($opt{'debug'}) && $opt{'debug'} > $DEBUG; + + warn "$me due_cust_event called with options ". + join(', ', map { "$_: $opt{$_}" } keys %opt). "\n" + if $DEBUG; + + $opt{'time'} ||= time; + + 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; + + $self->select_for_update; #mutex + + ### + # 1: find possible events (initial search) + ### + + my @cust_event = (); + + my @eventtable = $opt{'eventtable'} + ? ( $opt{'eventtable'} ) + : FS::part_event->eventtables_runorder; + + foreach my $eventtable ( @eventtable ) { + + my @objects; + if ( $opt{'objects'} ) { + + @objects = @{ $opt{'objects'} }; + + } else { + + #my @objects = $self->eventtable(); # sub cust_main { @{ [ $self ] }; } + @objects = ( $eventtable eq 'cust_main' ) + ? ( $self ) + : ( $self->$eventtable() ); + + } + + my @e_cust_event = (); + + my $cross = "CROSS JOIN $eventtable"; + $cross .= ' LEFT JOIN cust_main USING ( custnum )' + unless $eventtable eq 'cust_main'; + + foreach my $object ( @objects ) { + + #this first search uses the condition_sql magic for optimization. + #the more possible events we can eliminate in this step the better + + my $cross_where = ''; + my $pkey = $object->primary_key; + $cross_where = "$eventtable.$pkey = ". $object->$pkey(); + + my $join = FS::part_event_condition->join_conditions_sql( $eventtable ); + my $extra_sql = + FS::part_event_condition->where_conditions_sql( $eventtable, + 'time'=>$opt{'time'} + ); + my $order = FS::part_event_condition->order_conditions_sql( $eventtable ); + + $extra_sql = "AND $extra_sql" if $extra_sql; + + #here is the agent virtualization + $extra_sql .= " AND ( part_event.agentnum IS NULL + OR part_event.agentnum = ". $self->agentnum. ' )'; + + $extra_sql .= " $order"; + + my @part_event = qsearch( { + 'select' => 'part_event.*', + 'table' => 'part_event', + 'addl_from' => "$cross $join", + 'hashref' => { 'check_freq' => ( $opt{'check_freq'} || '1d' ), + 'eventtable' => $eventtable, + 'disabled' => '', + }, + 'extra_sql' => "AND $cross_where $extra_sql", + } ); + + if ( $DEBUG > 2 ) { + my $pkey = $object->primary_key; + warn " ". scalar(@part_event). + " possible events found for $eventtable ". $object->$pkey(). "\n"; } + push @e_cust_event, map { $_->new_cust_event($object) } @part_event; + } + warn " ". scalar(@e_cust_event). + " subtotal possible cust events found for $eventtable" + if $DEBUG > 1; + + push @cust_event, @e_cust_event; + + } + + warn " ". scalar(@cust_event). + " total possible cust events found in initial search\n" + if $DEBUG; # > 1; + + ## + # 2: test conditions + ## + + my %unsat = (); + + @cust_event = grep $_->test_conditions( 'time' => $opt{'time'}, + 'stats_hashref' => \%unsat ), + @cust_event; + + warn " ". scalar(@cust_event). " cust events left satisfying conditions\n" + if $DEBUG; # > 1; + + warn " invalid conditions not eliminated with condition_sql:\n". + join('', map " $_: ".$unsat{$_}."\n", keys %unsat ); + + ## + # 3: insert + ## + + foreach my $cust_event ( @cust_event ) { + + my $error = $cust_event->insert(); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } $dbh->commit or die $dbh->errstr if $oldAutoCommit; - ''; + + ## + # 4: return + ## + + warn " returning events: ". Dumper(@cust_event). "\n" + if $DEBUG > 2; + + \@cust_event; } @@ -2366,9 +2689,9 @@ 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 -event to "failed". +Implementation details: For either this customer, or for each of this +customer's open invoices, changes the status of the first "done" (with +statustext error) realtime processing event to "failed". =cut @@ -2386,25 +2709,52 @@ sub retry_realtime { local $FS::UID::AutoCommit = 0; my $dbh = dbh; - foreach my $cust_bill ( - grep { $_->cust_bill_event } - $self->open_cust_bill - ) { - my @cust_bill_event = - sort { $a->part_bill_event->seconds <=> $b->part_bill_event->seconds } - grep { - #$_->part_bill_event->plan eq 'realtime-card' - $_->part_bill_event->eventcode =~ - /\$cust_bill\->(batch|realtime)_(card|ach|lec)/ - && $_->status eq 'done' - && $_->statustext - } - $cust_bill->cust_bill_event; - next unless @cust_bill_event; - my $error = $cust_bill_event[0]->retry; + #a little false laziness w/due_cust_event (not too bad, really) + + my $join = FS::part_event_condition->join_conditions_sql; + my $order = FS::part_event_condition->order_conditions_sql; + + #here is the agent virtualization + my $agent_virt = " ( part_event.agentnum IS NULL + OR part_event.agentnum = ". $self->agentnum. ' )'; + + #XXX this shouldn't be hardcoded, actions should declare it... + my @realtime_events = qw( + cust_bill_realtime_card + cust_bill_realtime_check + cust_bill_realtime_lec + cust_bill_batch + ); + + my $is_realtime_event = ' ( '. join(' OR ', map "part_event.action = '$_'", + @realtime_events + ). + ' ) '; + + my @cust_event = qsearchs({ + 'table' => 'cust_event', + 'addl_from' => "LEFT JOIN part_event USING ( eventpart ) $join", + 'hashref' => { 'status' => 'done' }, + 'extra_sql' => " AND statustext IS NOT NULL AND statustext != '' ". + " AND $is_realtime_event AND $agent_virt $order" # LIMIT 1" + }); + + my %seen_invnum = (); + foreach my $cust_event (@cust_event) { + + #max one for the customer, one for each open invoice + my $cust_X = $cust_event->cust_X; + next if $seen_invnum{ $cust_event->part_event->eventtable eq 'cust_bill' + ? $cust_X->invnum + : 0 + }++ + or $cust_event->part_event->eventtable eq 'cust_bill' + && ! $cust_X->owed; + + my $error = $cust_event->retry; if ( $error ) { $dbh->rollback if $oldAutoCommit; - return "error scheduling invoice event for retry: $error"; + return "error scheduling event for retry: $error"; } } @@ -2457,6 +2807,22 @@ sub realtime_bop { ? $options{'payinfo'} : $self->payinfo; + my %method2payby = ( + 'CC' => 'CARD', + 'ECHECK' => 'CHEK', + 'LEC' => 'LECB', + ); + + ### + # check for banned credit card/ACH + ### + + my $ban = qsearchs('banned_pay', { + 'payby' => $method2payby{$method}, + 'payinfo' => md5_base64($payinfo), + } ); + return "Banned credit card" if $ban; + ### # select a gateway ### @@ -3596,17 +3962,38 @@ sub total_unapplied_payments { sprintf( "%.2f", $total_unapplied ); } +=item total_unapplied_refunds + +Returns the total unrefunded refunds (see L<FS::cust_refund>) for this +customer. See L<FS::cust_refund/unapplied>. + +=cut + +sub total_unapplied_refunds { + my $self = shift; + my $total_unapplied = 0; + foreach my $cust_refund ( qsearch('cust_refund', { + 'custnum' => $self->custnum, + } ) ) { + $total_unapplied += $cust_refund->unapplied; + } + sprintf( "%.2f", $total_unapplied ); +} + =item balance -Returns the balance for this customer (total_owed minus total_credited -minus total_unapplied_payments). +Returns the balance for this customer (total_owed plus total_unrefunded, minus +total_credited minus total_unapplied_payments). =cut sub balance { my $self = shift; sprintf( "%.2f", - $self->total_owed - $self->total_credited - $self->total_unapplied_payments + $self->total_owed + + $self->total_unapplied_refunds + - $self->total_credited + - $self->total_unapplied_payments ); } @@ -3624,7 +4011,8 @@ sub balance_date { my $self = shift; my $time = shift; sprintf( "%.2f", - $self->total_owed_date($time) + $self->total_owed_date($time) + + $self->total_unapplied_refunds - $self->total_credited - $self->total_unapplied_payments ); @@ -4068,6 +4456,17 @@ sub cust_pay_void { qsearch( 'cust_pay_void', { 'custnum' => $self->custnum } ) } +=item cust_pay_batch + +Returns all batched payments (see L<FS::cust_pay_void>) for this customer. + +=cut + +sub cust_pay_batch { + my $self = shift; + sort { $a->_date <=> $b->_date } + qsearch( 'cust_pay_batch', { 'custnum' => $self->custnum } ) +} =item cust_refund @@ -4206,13 +4605,13 @@ Returns a hex triplet color string for this customer's status. =cut use vars qw(%statuscolor); -%statuscolor = ( +tie my %statuscolor, 'Tie::IxHash', 'prospect' => '7e0079', #'000000', #black? naw, purple 'active' => '00CC00', #green 'inactive' => '0000CC', #blue 'suspended' => 'FF9900', #yellow 'cancelled' => 'FF0000', #red -); +; sub statuscolor { shift->cust_statuscolor(@_); } @@ -4227,6 +4626,20 @@ sub cust_statuscolor { =over 4 +=item statuses + +Class method that returns the list of possible status strings for customers +(see L<the status method|/status>). For example: + + @statuses = FS::cust_main->statuses(); + +=cut + +sub statuses { + #my $self = shift; #could be class... + keys %statuscolor; +} + =item prospect_sql Returns an SQL expression identifying prospective cust_main records (customers @@ -4329,6 +4742,65 @@ sub uncancel_sql { " ) "; } +=item balance_sql + +Returns an SQL fragment to retreive the balance. + +=cut + +sub balance_sql { " + COALESCE( ( SELECT SUM(charged) FROM cust_bill + WHERE cust_bill.custnum = cust_main.custnum ), 0) + - COALESCE( ( SELECT SUM(paid) FROM cust_pay + WHERE cust_pay.custnum = cust_main.custnum ), 0) + - COALESCE( ( SELECT SUM(amount) FROM cust_credit + WHERE cust_credit.custnum = cust_main.custnum ), 0) + + COALESCE( ( SELECT SUM(refund) FROM cust_refund + WHERE cust_refund.custnum = cust_main.custnum ), 0) +"; } + +=item balance_date_sql TIME + +Returns an SQL fragment to retreive the balance for this customer, only +considering invoices with date earlier than TIME. (total_owed_date minus total_credited minus +total_unapplied_payments). TIME is specified as an SQL fragment or a numeric +UNIX timestamp; see L<perlfunc/"time">). Also see L<Time::Local> and +L<Date::Parse> for conversion functions. + +=cut + +sub balance_date_sql { + my( $class, $time ) = @_; + + my $owed_sql = FS::cust_bill->owed_sql; + my $unapp_refund_sql = FS::cust_refund->unapplied_sql; + #my $unapp_credit_sql = FS::cust_credit->unapplied_sql; + my $unapp_credit_sql = FS::cust_credit->credited_sql; + my $unapp_pay_sql = FS::cust_pay->unapplied_sql; + + " + COALESCE( ( SELECT SUM($owed_sql) FROM cust_bill + WHERE cust_bill.custnum = cust_main.custnum + AND cust_bill._date <= $time ) + ,0 + ) + + COALESCE( ( SELECT SUM($unapp_refund_sql) FROM cust_refund + WHERE cust_refund.custnum = cust_main.custnum ) + ,0 + ) + - COALESCE( ( SELECT SUM($unapp_credit_sql) FROM cust_credit + WHERE cust_credit.custnum = cust_main.custnum ) + ,0 + ) + - COALESCE( ( SELECT SUM($unapp_pay_sql) FROM cust_pay + WHERE cust_pay.custnum = cust_main.custnum ) + ,0 + ) + + "; + +} + =item fuzzy_search FUZZY_HASHREF [ HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ ] Performs a fuzzy (approximate) search and returns the matching FS::cust_main @@ -4552,9 +5024,10 @@ sub smart_search { 'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization } ); - #always do substring & fuzzy, - #getting complains searches are not returning enough - unless ( @cust_main && $skip_fuzzy ) { #no exact match, trying substring/fuzzy + #no exact match, trying substring/fuzzy + #always do substring & fuzzy (unless they're explicity config'ed off) + #getting complaints searches are not returning enough + unless ( @cust_main && $skip_fuzzy || $conf->exists('disable-fuzzy') ) { #still some false laziness w/ search/cust_main.cgi @@ -5158,7 +5631,7 @@ sub generate_letter { unless(exists($letter_data{returnaddress})){ my $retadd = join("\n", $conf->config_orbase( 'invoice_latexreturnaddress', - $self->_agent_template) + $self->agent_template) ); $letter_data{returnaddress} = length($retadd) ? $retadd : '~'; @@ -5227,32 +5700,53 @@ sub agent_invoice_from { sub _agent_plandata { my( $self, $option ) = @_; - my $part_bill_event = qsearchs( 'part_bill_event', - { - 'payby' => $self->payby, - 'plan' => 'send_agent', - 'plandata' => { 'op' => '~', - 'value' => "(^|\n)agentnum ". - '([0-9]*, )*'. - $self->agentnum. - '(, [0-9]*)*'. - "(\n|\$)", - }, - }, - '', - 'ORDER BY seconds LIMIT 1' - ); - - return '' unless $part_bill_event; - - if ( $part_bill_event->plandata =~ /^$option (.*)$/m ) { - return $1; - } else { - warn "can't parse part_bill_event eventpart#". $part_bill_event->eventpart. - " plandata for $option"; + #yuck. this whole thing needs to be reconciled better with 1.9's idea of + #agent-specific Conf + + my $agentnum = $self->agentnum; + + my $part_event_option = + qsearchs({ + 'table' => 'part_event_option', + 'addl_from' => q{ + LEFT JOIN part_event USING ( eventpart ) + LEFT JOIN part_event_option AS peo_agentnum + ON ( part_event.eventpart = peo_agentnum.eventpart + AND peo_agentnum.optionname = 'agentnum' + AND peo_agentnum.optionvalue ~ '(^|,)agentnum(,|$)' + ) + LEFT JOIN part_event_option AS peo_cust_bill_age + ON ( part_event.eventpart = peo_cust_bill_age.eventpart + AND peo_cust_bill_age.optionname = 'cust_bill_age' + ) + }, + #'hashref' => { 'optionname' => $option }, + 'hashref' => { 'part_event_option.optionname' => $option }, + 'extra_sql' => " AND event = 'cust_bill_send_agent' ". + " AND peo_agentnum.optionname = 'agentnum' ". + " AND agentnum IS NULL OR agentnum = $agentnum ". + " ORDER BY + CASE WHEN peo_cust_bill_age.optionname != 'cust_bill_age' + THEN -1 + ELSE EXTRACT( EPOCH FROM + REPLACE( peo_cust_bill_age.optionvalue, + 'm', + 'mon' + )::interval + ) + END + , part_event.weight". + " LIMIT 1" + }); + + unless ( $part_event_option ) { + return $self->agent->invoice_template || '' + if $option eq '$agent_templatename'; return ''; } + $part_event_option->optionvalue; + } =back @@ -5279,6 +5773,8 @@ Birthdates rely on negative epoch values. The payby for card/check batches is broken. With mixed batching, bad things will happen. +B<collect> I<invoice_time> should be renamed I<time>, like B<bill>. + =head1 SEE ALSO L<FS::Record>, L<FS::cust_pkg>, L<FS::cust_bill>, L<FS::cust_credit> diff --git a/FS/FS/cust_pay.pm b/FS/FS/cust_pay.pm index 23bcdd9..5d31d2c 100644 --- a/FS/FS/cust_pay.pm +++ b/FS/FS/cust_pay.pm @@ -550,6 +550,36 @@ sub cust_main { =back +=head1 CLASS METHODS + +=over 4 + +=item unapplied_sql + +Returns an SQL fragment to retreive the unapplied amount. + +=cut + +sub unapplied_sql { + #my $class = shift; + + "paid + - COALESCE( + ( SELECT SUM(amount) FROM cust_bill_pay + WHERE cust_pay.paynum = cust_bill_pay.paynum ) + ,0 + ) + - COALESCE( + ( SELECT SUM(amount) FROM cust_pay_refund + WHERE cust_pay.paynum = cust_pay_refund.paynum ) + ,0 + ) + "; + +} + +=back + =head1 BUGS Delete and replace methods. diff --git a/FS/FS/cust_pay_batch.pm b/FS/FS/cust_pay_batch.pm index 573f06f..9ef1e1c 100644 --- a/FS/FS/cust_pay_batch.pm +++ b/FS/FS/cust_pay_batch.pm @@ -2,11 +2,14 @@ package FS::cust_pay_batch; use strict; use vars qw( @ISA $DEBUG ); +use Carp qw( confess ); +use Business::CreditCard 0.28; use FS::Record qw(dbh qsearch qsearchs); use FS::payinfo_Mixin; -use Business::CreditCard 0.28; +use FS::cust_main; +use FS::cust_bill; -@ISA = qw( FS::Record FS::payinfo_Mixin ); +@ISA = qw( FS::payinfo_Mixin FS::Record ); # 1 is mostly method/subroutine entry and options # 2 traces progress of some operations @@ -32,7 +35,7 @@ FS::cust_pay_batch - Object methods for batch cards $error = $record->check; - $error = $record->retriable; + #deprecated# $error = $record->retriable; =head1 DESCRIPTION @@ -201,19 +204,27 @@ sub cust_main { qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); } -=item retriable - -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. +#you know what, screw this in the new world of events. we should be able to +#get the event defs to retry (remove once.pm condition, add every.pm) without +#mucking about with statuses of previous cust_event records. right? +# +#=item retriable +# +#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. +# +#Implementation details: For the named customer's invoice, changes the +#statustext of the 'done' (without statustext) event to 'retriable.' +# +#=cut -Implementation details: For the named customer's invoice, changes the -statustext of the 'done' (without statustext) event to 'retriable.' +sub retriable { -=cut + confess "deprecated method cust_pay_batch->retriable called; try removing ". + "the once condition and adding an every condition?"; -sub retriable { my $self = shift; local $SIG{HUP} = 'IGNORE'; #Hmm diff --git a/FS/FS/cust_pkg.pm b/FS/FS/cust_pkg.pm index f2b0395..571bf0e 100644 --- a/FS/FS/cust_pkg.pm +++ b/FS/FS/cust_pkg.pm @@ -7,6 +7,7 @@ use Tie::IxHash; use FS::UID qw( getotaker dbh ); use FS::Misc qw( send_email ); use FS::Record qw( qsearch qsearchs ); +use FS::m2m_Common; use FS::cust_main_Mixin; use FS::cust_svc; use FS::part_pkg; @@ -14,6 +15,7 @@ use FS::cust_main; use FS::type_pkgs; use FS::pkg_svc; use FS::cust_bill_pkg; +use FS::cust_event; use FS::h_cust_svc; use FS::reg_code; use FS::part_svc; @@ -31,7 +33,7 @@ use FS::svc_forward; # for sending cancel emails in sub cancel use FS::Conf; -@ISA = qw( FS::cust_main_Mixin FS::option_Common FS::Record ); +@ISA = qw( FS::m2m_Common FS::cust_main_Mixin FS::option_Common FS::Record ); $DEBUG = 0; @@ -157,6 +159,12 @@ If the additional field I<promo_code> is defined instead of I<pkgpart>, it will be used to look up the package definition and agent restrictions will be ignored. +If the additional field I<refnum> is defined, an FS::pkg_referral record will +be created and inserted. Multiple FS::pkg_referral records can be created by +setting I<refnum> to an array reference of refnums or a hash reference with +refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral +record will be created corresponding to cust_main.refnum. + The following options are available: I<change> I<change>, if set true, supresses any referral credit to a referring customer. @@ -183,6 +191,13 @@ sub insert { return $error; } + $self->refnum($self->cust_main->refnum) unless $self->refnum; + $self->refnum( [ $self->refnum ] ) unless ref($self->refnum); + $self->process_m2m( 'link_table' => 'pkg_referral', + 'target_table' => 'part_referral', + 'params' => $self->refnum, + ); + #if ( $self->reg_code ) { # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } ); # $error = $reg_code->delete; @@ -315,7 +330,7 @@ sub replace { foreach my $method ( qw(adjourn expire) ) { # How many reasons? if ($options{'reason'} && $new->$method && $old->$method ne $new->$method) { my $error = $new->insert_reason( 'reason' => $options{'reason'}, - 'date' => $new->$method, + 'date' => $new->$method, ); if ( $error ) { dbh->rollback if $oldAutoCommit; @@ -441,9 +456,17 @@ Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>) in this package, then cancels the package itself (sets the cancel field to now). -Available options are: I<quiet> +Available options are: + +=over 4 + +=item quiet - can be set true to supress email cancellation notices. -I<quiet> can be set true to supress email cancellation notices. +=item time - can be set to cancel the package based on a specific future or historical date. Using time ensures that the remaining amount is calculated correctly. Note however that this is an immediate cancel and just changes the date. You are PROBABLY looking to expire the account instead of using this. + +=item reason - can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason. The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason. + +=back If there is an error, returns the error, otherwise returns false. @@ -451,7 +474,10 @@ If there is an error, returns the error, otherwise returns false. sub cancel { my( $self, %options ) = @_; - my $error; + + warn "cust_pkg::cancel called with options". + join(', ', map { "$_: $options{$_}" } keys %options ). "\n" + if $DEBUG; local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; @@ -463,8 +489,12 @@ sub cancel { my $oldAutoCommit = $FS::UID::AutoCommit; local $FS::UID::AutoCommit = 0; my $dbh = dbh; + + my $cancel_time = $options{'time'} || time; - if ($options{'reason'}) { + my $error; + + if ( $options{'reason'} ) { $error = $self->insert_reason( 'reason' => $options{'reason'} ); if ( $error ) { dbh->rollback if $oldAutoCommit; @@ -489,23 +519,22 @@ sub cancel { } } - # Add a credit for remaining service - my $remaining_value = $self->calc_remain(); - if ( $remaining_value > 0 ) { - my $error = $self->cust_main->credit( - $remaining_value, - 'Credit for unused time on '. $self->part_pkg->pkg, - ); - if ($error) { - $dbh->rollback if $oldAutoCommit; - return "Error crediting customer \$$remaining_value for unused time on". - $self->part_pkg->pkg. ": $error"; - } - } - unless ( $self->getfield('cancel') ) { + # Add a credit for remaining service + my $remaining_value = $self->calc_remain(time=>$cancel_time); + if ( $remaining_value > 0 && !$options{'no_credit'} ) { + my $error = $self->cust_main->credit( + $remaining_value, + 'Credit for unused time on '. $self->part_pkg->pkg, + ); + if ($error) { + $dbh->rollback if $oldAutoCommit; + return "Error crediting customer \$$remaining_value for unused time on". + $self->part_pkg->pkg. ": $error"; + } + } my %hash = $self->hash; - $hash{'cancel'} = time; + $hash{'cancel'} = $cancel_time; my $new = new FS::cust_pkg ( \%hash ); $error = $new->replace( $self, options => { $self->options } ); if ( $error ) { @@ -533,18 +562,43 @@ sub cancel { } -=item suspend +=item cancel_if_expired [ NOW_TIMESTAMP ] + +Cancels this package if its expire date has been reached. + +=cut + +sub cancel_if_expired { + my $self = shift; + my $time = shift || time; + return '' unless $self->expire && $self->expire <= $time; + my $error = $self->cancel; + if ( $error ) { + return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ". + $self->custnum. ": $error"; + } + ''; +} + +=item suspend [ OPTION => VALUE ... ] Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this package, then suspends the package itself (sets the susp field to now). +Available options are: + +=over 4 + +=item reason - can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason. The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason. + +=back + If there is an error, returns the error, otherwise returns false. =cut sub suspend { my( $self, %options ) = @_; - my $error ; local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; @@ -557,7 +611,9 @@ sub suspend { local $FS::UID::AutoCommit = 0; my $dbh = dbh; - if ($options{'reason'}) { + my $error; + + if ( $options{'reason'} ) { $error = $self->insert_reason( 'reason' => $options{'reason'} ); if ( $error ) { dbh->rollback if $oldAutoCommit; @@ -796,6 +852,40 @@ sub cust_bill_pkg { qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } ); } +=item cust_event + +Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice. + +=cut + +#false laziness w/cust_bill.pm +sub cust_event { + my $self = shift; + qsearch({ + 'table' => 'cust_event', + 'addl_from' => 'JOIN part_event USING ( eventpart )', + 'hashref' => { 'tablenum' => $self->pkgnum }, + 'extra_sql' => " AND eventtable = 'cust_pkg' ", + }); +} + +=item num_cust_event + +Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice. + +=cut + +#false laziness w/cust_bill.pm +sub num_cust_event { + my $self = shift; + my $sql = + "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ". + " WHERE tablenum = ? AND eventtable = 'cust_pkg'"; + my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql"; + $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql"; + $sth->fetchrow_arrayref->[0]; +} + =item cust_svc [ SVCPART ] Returns the services for this package, as FS::cust_svc objects (see @@ -1023,7 +1113,7 @@ sub status { =item statuses -Class method that returns the list of possible status strings for pacakges +Class method that returns the list of possible status strings for packages (see L<the status method|/status>). For example: @statuses = FS::cust_pkg->statuses(); @@ -1449,7 +1539,7 @@ sub cancel_sql { =over 4 -=item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ] +=item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ] CUSTNUM is a customer (see L<FS::cust_main>) @@ -1466,10 +1556,16 @@ parameter. RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the newly-created cust_pkg objects. +REFNUM, if specified, will specify the FS::pkg_referral record to be created +and inserted. Multiple FS::pkg_referral records can be created by +setting I<refnum> to an array reference of refnums or a hash reference with +refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral +record will be created corresponding to cust_main.refnum. + =cut sub order { - my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_; + my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_; my $conf = new FS::Conf; @@ -1504,6 +1600,7 @@ sub order { foreach my $pkgpart (@$pkgparts) { my $cust_pkg = new FS::cust_pkg { custnum => $custnum, pkgpart => $pkgpart, + refnum => $refnum, %hash, }; $error = $cust_pkg->insert( 'change' => $change ); @@ -1557,11 +1654,54 @@ sub order { ''; } +=item insert_reason + +Associates this package with a (suspension or cancellation) reason (see +L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see +L<FS::reason>). + +Available options are: + +=over 4 + +=item reason - can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason. The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason. + +=item date + +=back + +If there is an error, returns the error, otherwise returns false. + +=cut + sub insert_reason { my ($self, %options) = @_; my $otaker = $FS::CurrentUser::CurrentUser->username; + my $reasonnum; + if ( $options{'reason'} =~ /^(\d+)$/ ) { + + $reasonnum = $1; + + } elsif ( ref($options{'reason'}) ) { + + return 'Enter a new reason (or select an existing one)' + unless $options{'reason'}->{'reason'} !~ /^\s*$/; + + my $reason = new FS::reason({ + 'reason_type' => $options{'reason'}->{'typenum'}, + 'reason' => $options{'reason'}->{'reason'}, + }); + my $error = $reason->insert; + return $error if $error; + + $reasonnum = $reason->reasonnum; + + } else { + return "Unparsable reason: ". $options{'reason'}; + } + my $cust_pkg_reason = new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum, 'reasonnum' => $options{'reason'}, @@ -1570,7 +1710,8 @@ sub insert_reason { ? $options{'date'} : time, }); - return $cust_pkg_reason->insert; + + $cust_pkg_reason->insert; } =item set_usage USAGE_VALUE_HASHREF diff --git a/FS/FS/cust_refund.pm b/FS/FS/cust_refund.pm index 9cd9bf8..53c6bac 100644 --- a/FS/FS/cust_refund.pm +++ b/FS/FS/cust_refund.pm @@ -221,7 +221,8 @@ Currently unimplemented (accounting reasons). =cut sub replace { - return "Can't (yet?) modify cust_refund records!"; + my $self = shift; + $self->SUPER::replace(@_); } =item check @@ -307,6 +308,36 @@ sub unapplied { =back +=head1 CLASS METHODS + +=over 4 + +=item unapplied_sql + +Returns an SQL fragment to retreive the unapplied amount. + +=cut + +sub unapplied_sql { + #my $class = shift; + + "refund + - COALESCE( + ( SELECT SUM(amount) FROM cust_credit_refund + WHERE cust_refund.refundnum = cust_credit_refund.refundnum ) + ,0 + ) + - COALESCE( + ( SELECT SUM(amount) FROM cust_pay_refund + WHERE cust_refund.refundnum = cust_pay_refund.refundnum ) + ,0 + ) + "; + +} + +=back + =head1 BUGS Delete and replace methods. diff --git a/FS/FS/m2name_Common.pm b/FS/FS/m2name_Common.pm index 7c9637e..e9dcee9 100644 --- a/FS/FS/m2name_Common.pm +++ b/FS/FS/m2name_Common.pm @@ -1,34 +1,51 @@ package FS::m2name_Common; use strict; -use vars qw( @ISA $DEBUG ); +use vars qw( $DEBUG $me ); +use Carp; use FS::Schema qw( dbdef ); -use FS::Record qw( qsearch qsearchs ); #dbh ); - -@ISA = qw( FS::Record ); +use FS::Record qw( qsearchs ); #qsearch dbh ); $DEBUG = 0; +$me = '[FS::m2name_Common]'; + =head1 NAME -FS::m2name_Common - Base class for tables with a related table listing names +FS::m2name_Common - Mixin class for tables with a related table listing names =head1 SYNOPSIS use FS::m2name_Common; -@ISA = qw( FS::m2name_Common ); +@ISA = qw( FS::m2name_Common FS::Record ); =head1 DESCRIPTION -FS::m2name_Common is intended as a base class for classes which have a +FS::m2name_Common is intended as a mixin class for classes which have a related table that lists names. =head1 METHODS =over 4 -=item process_m2name +=item process_m2name OPTION => VALUE, ... + +Available options: + +link_table (required) - Table into which the records are inserted. + +num_col (optional) - Column in link_table which links to the primary key of the base table. If not specified, it is assumed this has the same name. + +name_col (required) - Name of the column in link_table that stores the string names. + +names_list (required) - List reference of the possible string name values. + +params (required) - Hashref of keys and values, often passed as C<scalar($cgi->Vars)> from a form. Processing is controlled by the B<param_style param> option. + +param_style (required) - Controls processing of B<params>. I<'link_table.value checkboxes'> specifies that parameters keys are in the form C<link_table.name>, and the values are booleans controlling whether or not to insert that name into link_table. I<'name_colN values'> specifies that parameter keys are in the form C<name_col0>, C<name_col1>, and so on, and values are the names inserted into link_table. + +args_callback (optional) - Coderef. Optional callback that may modify arguments for insert and replace operations. The callback is run with four arguments: the first argument is object being inserted or replaced (i.e. FS::I<link_table> object), the second argument is a prefix to use when retreiving CGI arguements from the params hashref, the third argument is the params hashref (see above), and the final argument is a listref of arguments that the callback should modify. =cut @@ -42,21 +59,61 @@ sub process_m2name { my $link_static = $opt{'link_static'} || {}; + warn "$me processing m2name from ". $self->table. ".$link_sourcekey". + " to $link_table\n" + if $DEBUG; + foreach my $name ( @{ $opt{'names_list'} } ) { + warn "$me checking $name\n" if $DEBUG; + + my $name_col = $opt{'name_col'}; + my $obj = qsearchs( $link_table, { $link_sourcekey => $self->$self_pkey(), - $opt{'name_col'} => $name, + $name_col => $name, %$link_static, }); - if ( $obj && ! $opt{'params'}->{"$link_table.$name"} ) { + my $param = ''; + my $prefix = ''; + if ( $opt{'param_style'} =~ /link_table.value\s+checkboxes/i ) { + #access_group.html style + my $paramname = "$link_table.$name"; + $param = $opt{'params'}->{$paramname}; + } elsif ( $opt{'param_style'} =~ /name_colN values/i ) { + #part_event.html style + + my @fields = grep { /^$name_col\d+$/ } + keys %{$opt{'params'}}; + + $param = grep { $name eq $opt{'params'}->{$_} } @fields; + + if ( $param ) { + #this depends on their being one condition per name... + #which needs to be enforced on the edit page... + #(it is on part_event and access_group edit) + foreach my $field (@fields) { + $prefix = "$field." if $name eq $opt{'params'}->{$field}; + } + warn "$me prefix $prefix\n" if $DEBUG; + } + } else { #?? + croak "unknown param_style: ". $opt{'param_style'}; + $param = $opt{'params'}->{$name}; + } + + if ( $obj && ! $param ) { + + warn "$me deleting $name\n" if $DEBUG; 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 ) { + } elsif ( $param && ! $obj ) { + + warn "$me inserting $name\n" if $DEBUG; #ok to clobber it now (but bad form nonetheless?) #$obj = new "FS::$link_table" ( { @@ -65,8 +122,33 @@ sub process_m2name { $opt{'name_col'} => $name, %$link_static, }); - my $error = $obj->insert; + + my @args = (); + if ( $opt{'args_callback'} ) { #edit/process/part_event.html + &{ $opt{'args_callback'} }( $obj, + $prefix, + $opt{'params'}, + \@args + ); + } + + my $error = $obj->insert( @args ); die "error inserting $obj for $link_table.$name: $error" if $error; + + } elsif ( $param && $obj && $opt{'args_callback'} ) { + + my @args = (); + if ( $opt{'args_callback'} ) { #edit/process/part_event.html + &{ $opt{'args_callback'} }( $obj, + $prefix, + $opt{'params'}, + \@args + ); + } + + my $error = $obj->replace( $obj, @args ); + die "error replacing $obj for $link_table.$name: $error" if $error; + } } diff --git a/FS/FS/option_Common.pm b/FS/FS/option_Common.pm index 2950b28..441e798 100644 --- a/FS/FS/option_Common.pm +++ b/FS/FS/option_Common.pm @@ -79,10 +79,13 @@ sub insert { my $valuecol = $self->_option_valuecol; foreach my $optionname ( keys %{$options} ) { + + my $optionvalue = $options->{$optionname}; + my $href = { $pkey => $self->get($pkey), $namecol => $optionname, - $valuecol => $options->{$optionname}, + $valuecol => ( ref($optionvalue) || $optionvalue ), }; #my $option_record = eval "new FS::$option_table \$href"; @@ -92,11 +95,15 @@ sub insert { #} my $option_record = "FS::$option_table"->new($href); - $error = $option_record->insert; + my @args = (); + push @args, $optionvalue if ref($optionvalue); #only hashes supported so far + + $error = $option_record->insert(@args); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; } + } $dbh->commit or die $dbh->errstr if $oldAutoCommit; @@ -154,8 +161,8 @@ sub delete { Replaces the OLD_RECORD with this one in the database. If there is an error, returns the error, otherwise returns false. -If a list hash reference of options is supplied, part_export_option records are -created or modified (see L<FS::part_export_option>). +If a list hash reference of options is supplied, option records are created or +modified. =cut @@ -208,10 +215,15 @@ sub replace { $namecol => $optionname, } ); + my $optionvalue = $options->{$optionname}; + + my %oldhash = $oldopt ? $oldopt->hash : (); + my $href = { + %oldhash, $pkey => $self->get($pkey), $namecol => $optionname, - $valuecol => $options->{$optionname}, + $valuecol => ( ref($optionvalue) || $optionvalue ), }; #my $newopt = eval "new FS::$option_table \$href"; @@ -224,10 +236,15 @@ sub replace { my $opt_pkey = $newopt->primary_key; $newopt->$opt_pkey($oldopt->$opt_pkey) if $oldopt; + + my @args = (); + push @args, $optionvalue if ref($optionvalue); #only hashes supported so far + warn "FS::option_Common::replace: ". ( $oldopt ? "$newopt -> replace($oldopt)" : "$newopt -> insert" ) if $DEBUG > 2; - my $error = $oldopt ? $newopt->replace($oldopt) : $newopt->insert; + my $error = $oldopt ? $newopt->replace($oldopt, @args) + : $newopt->insert( @args); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; diff --git a/FS/FS/part_bill_event.pm b/FS/FS/part_bill_event.pm index 683f484..1d48af9 100644 --- a/FS/FS/part_bill_event.pm +++ b/FS/FS/part_bill_event.pm @@ -2,6 +2,7 @@ package FS::part_bill_event; use strict; use vars qw( @ISA $DEBUG @EXPORT_OK ); +use Carp qw(cluck confess); use FS::Record qw( dbh qsearch qsearchs ); use FS::Conf; @@ -37,10 +38,10 @@ FS::part_bill_event - Object methods for part_bill_event records =head1 DESCRIPTION -An FS::part_bill_event object represents an invoice event definition - -a callback which is triggered when an invoice is a certain amount of time -overdue. FS::part_bill_event inherits from -FS::Record. The following fields are currently supported: +An FS::part_bill_event object represents a deprecated, old-style invoice event +definition - a callback which is triggered when an invoice is a certain amount +of time overdue. FS::part_bill_event inherits from FS::Record. The following +fields are currently supported: =over 4 @@ -66,6 +67,11 @@ FS::Record. The following fields are currently supported: =back +=head1 NOTE + +Old-style invoice events are only useful for legacy migrations - if you are +looking for current events see L<FS::part_event>. + =head1 METHODS =over 4 @@ -226,6 +232,10 @@ Requires record and payby, but event_time and extra_sql are optional. sub due_events { my ($record, $payby, $event_time, $extra_sql) = @_; + + #cluck "DEPRECATED: FS::part_bill_event::due_events called on $record"; + confess "DEPRECATED: FS::part_bill_event::due_events called on $record"; + my $interval = 0; if ($record->_date){ $event_time = time unless $event_time; @@ -261,6 +271,10 @@ Should only be performed inside a transaction. sub do_event { my ($self, $object, %options) = @_; + + #cluck "DEPRECATED: FS::part_bill_event::do_event called on $self"; + confess "DEPRECATED: FS::part_bill_event::do_event called on $self"; + warn " calling event (". $self->eventcode. ") for " . $object->table . " " , $object->get($object->dbdef_table->primary_key) . "\n" if $DEBUG > 1; my $oldAutoCommit = $FS::UID::AutoCommit; diff --git a/FS/FS/part_event.pm b/FS/FS/part_event.pm new file mode 100644 index 0000000..09104cd --- /dev/null +++ b/FS/FS/part_event.pm @@ -0,0 +1,427 @@ +package FS::part_event; + +use strict; +use vars qw( @ISA $DEBUG ); +use Carp qw(confess); +use FS::Record qw( dbh qsearch qsearchs ); +use FS::option_Common; +use FS::m2name_Common; +use FS::Conf; +use FS::part_event_option; +use FS::part_event_condition; +use FS::cust_event; +use FS::agent; + +@ISA = qw( FS::m2name_Common FS::option_Common ); # FS::Record ); +$DEBUG = 0; + +=head1 NAME + +FS::part_event - Object methods for part_event records + +=head1 SYNOPSIS + + use FS::part_event; + + $record = new FS::part_event \%hash; + $record = new FS::part_event { 'column' => 'value' }; + + $error = $record->insert( { 'option' => 'value' } ); + $error = $record->insert( \%options ); + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + + $error = $record->do_event( $direct_object ); + +=head1 DESCRIPTION + +An FS::part_event object represents an event definition - a billing, collection +or other callback which is triggered when certain customer, invoice, package or +other conditions are met. FS::part_event inherits from FS::Record. The +following fields are currently supported: + +=over 4 + +=item eventpart - primary key + +=item agentnum - Optional agentnum (see L<FS::agent>) + +=item event - event name + +=item eventtable - table name against which this event is triggered; currently "cust_bill" (the traditional invoice events), "cust_main" (customer events) or "cust_pkg (package events) + +=item check_freq - how often events of this type are checked; currently "1d" (daily) and "1m" (monthly) are recognized. Note that the apprioriate freeside-daily and/or freeside-monthly cron job needs to be in place. + +=item weight - ordering for events + +=item action - event action (like part_bill_event.plan - eventcode plan) + +=item disabled - Disabled flag, empty or `Y' + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +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. + +=cut + +# the new method can be inherited from FS::Record, if a table method is defined + +sub table { 'part_event'; } + +=item insert [ HASHREF ] + +Adds this record to the database. If there is an error, returns the error, +otherwise returns false. + +If a list or hash reference of options is supplied, part_export_option records +are created (see L<FS::part_event_option>). + +=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 [ HASHREF | OPTION => VALUE ... ] + +Replaces the OLD_RECORD with this one in the database. If there is an error, +returns the error, otherwise returns false. + +If a list or hash reference of options is supplied, part_event_option +records are created or modified (see L<FS::part_event_option>). + +=cut + +# the replace method can be inherited from FS::Record + +=item check + +Checks all fields to make sure this is a valid invoice event definition. If +there is an error, returns the error, otherwise returns false. Called by the +insert and replace methods. + +=cut + +# the check method should currently be supplied - FS::Record contains some +# data checking routines + +sub check { + my $self = shift; + + $self->weight(0) unless $self->weight; + + my $error = + $self->ut_numbern('eventpart') + || $self->ut_text('event') + || $self->ut_enum('eventtable', [ 'cust_bill', 'cust_main', 'cust_pkg' ] ) + || $self->ut_enum('check_freq', [ '1d', '1m' ]) + || $self->ut_number('weight') + || $self->ut_alpha('action') + || $self->ut_enum('disabled', [ '', 'Y' ] ) + ; + return $error if $error; + + #XXX check action to make sure a module exists? + # well it'll die in _rebless... + + $self->SUPER::check; +} + +=item _rebless + +Reblesses the object into the FS::part_event::Action::ACTION class, where +ACTION is the object's I<action> field. + +=cut + +sub _rebless { + my $self = shift; + my $action = $self->action or return $self; + #my $class = ref($self). "::$action"; + my $class = "FS::part_event::Action::$action"; + eval "use $class"; + die $@ if $@; + bless($self, $class); # unless $@; + $self; +} + +=item part_event_condition + +Returns the conditions associated with this event, as FS::part_event_condition +objects (see L<FS::part_event_condition>) + +=cut + +sub part_event_condition { + my $self = shift; + qsearch( 'part_event_condition', { 'eventpart' => $self->eventpart } ); +} + +=item new_cust_event OBJECT + +Creates a new customer event (see L<FS::cust_event>) for the provided object. + +=cut + +sub new_cust_event { + my( $self, $object ) = @_; + + confess "**** $object is not a ". $self->eventtable + if ref($object) ne "FS::". $self->eventtable; + + my $pkey = $object->primary_key; + + new FS::cust_event { + 'eventpart' => $self->eventpart, + 'tablenum' => $object->$pkey(), + '_date' => time, #i think we always want the real "now" here. + 'status' => 'new', + }; +} + +#surely this doesn't work +sub reasontext { confess "part_event->reasontext deprecated"; } +#=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{ +# ''; +# } +#} + +=item agent + +Returns the associated agent for this event, if any, as an FS::agent object. + +=cut + +sub agent { + my $self = shift; + qsearchs('agent', { 'agentnum' => $self->agentnum } ); +} + +=item templatename + +Returns the alternate invoice template name, if any, or false if there is +no alternate template for this event. + +=cut + +sub templatename { + + my $self = shift; + if ( $self->action =~ /^cust_bill_send_(alternate|agent)$/ + && ( $self->option('agent_templatename') + || $self->option('templatename') ) + ) + { + $self->option('agent_templatename') + || $self->option('templatename'); + + } else { + ''; + } +} + +=back + +=head1 CLASS METHODS + +=over 4 + +=item eventtable_labels + +Returns a hash reference of labels for eventtable values, +i.e. 'cust_main'=>'Customer' + +=cut + +sub eventtable_labels { + #my $class = shift; + + tie my %hash, 'Tie::IxHash', + 'cust_pkg' => 'Package', + 'cust_bill' => 'Invoice', + 'cust_main' => 'Customer', + 'cust_pay_batch' => 'Batch payment', + ; + + \%hash +} + +=item eventtable_pkey_sql + +Returns a hash reference of full SQL primary key names for eventtable values, +i.e. 'cust_main'=>'cust_main.custnum' + +=cut + +sub eventtable_pkey_sql { + #my $class = shift; + + my %hash = ( + 'cust_main' => 'cust_main.custnum', + 'cust_bill' => 'cust_bill.invnum', + 'cust_pkg' => 'cust_pkg.pkgnum', + 'cust_pay_batch' => 'cust_pay_batch.paybatchnum', + ); + + \%hash; +} + + +=item eventtables + +Returns a list of eventtable values (default ordering; suited for display). + +=cut + +sub eventtables { + my $class = shift; + my $eventtables = $class->eventtable_labels; + keys %$eventtables; +} + +=item eventtables_runorder + +Returns a list of eventtable values (run order). + +=cut + +sub eventtables_runorder { + shift->eventtables; #same for now +} + +=item check_freq_labels + +Returns a hash reference of labels for check_freq values, +i.e. '1d'=>'daily' + +=cut + +sub check_freq_labels { + #my $class = shift; + + #Tie::IxHash?? + { + '1d' => 'daily', + '1m' => 'monthly', + }; +} + +=item actions [ EVENTTABLE ] + +Return information about the available actions. If an eventtable is specified, +only return information about actions available for that eventtable. + +Information is returned as key-value pairs. Keys are event names. Values are +hashrefs with the following keys: + +=over 4 + +=item description + +=item eventtable_hashref + +=item option_fields + +=item default_weight + +=item deprecated + +=back + +See L<FS::part_event::Action> for more information. + +=cut + +#false laziness w/part_event_condition.pm +#some false laziness w/part_export & part_pkg +my %actions; +foreach my $INC ( @INC ) { + foreach my $file ( glob("$INC/FS/part_event/Action/*.pm") ) { + warn "attempting to load Action from $file\n" if $DEBUG; + $file =~ /\/(\w+)\.pm$/ or do { + warn "unrecognized file in $INC/FS/part_event/Action/: $file\n"; + next; + }; + my $mod = $1; + eval "use FS::part_event::Action::$mod;"; + if ( $@ ) { + die "error using FS::part_event::Action::$mod (skipping): $@\n" if $@; + #warn "error using FS::part_event::Action::$mod (skipping): $@\n" if $@; + #next; + } + $actions{$mod} = { + ( map { $_ => "FS::part_event::Action::$mod"->$_() } + qw( description eventtable_hashref default_weight deprecated ) + #option_fields_hashref + ), + 'option_fields' => [ "FS::part_event::Action::$mod"->option_fields() ], + }; + } +} + +sub actions { + my( $class, $eventtable ) = @_; + ( + map { $_ => $actions{$_} } + sort { $actions{$a}->{'default_weight'}<=>$actions{$b}->{'default_weight'} } + $class->all_actions( $eventtable ) + ); + +} + +=item all_actions [ EVENTTABLE ] + +Returns a list of just the action names + +=cut + +sub all_actions { + my ( $class, $eventtable ) = @_; + + grep { !$eventtable || $actions{$_}->{'eventtable_hashref'}{$eventtable} } + keys %actions +} + +=back + +=head1 SEE ALSO + +L<FS::part_event_option>, L<FS::part_event_condition>, L<FS::cust_main>, +L<FS::cust_pkg>, L<FS::cust_bill>, L<FS::cust_bill_event>, L<FS::Record>, +schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/part_event/Action.pm b/FS/FS/part_event/Action.pm new file mode 100644 index 0000000..bdb9df6 --- /dev/null +++ b/FS/FS/part_event/Action.pm @@ -0,0 +1,224 @@ +package FS::part_event::Action; + +use strict; +use base qw( FS::part_event ); +use Tie::IxHash; + +=head1 NAME + +FS::part_event::Action - Base class for event actions + +=head1 SYNOPSIS + +package FS::part_event::Action::myaction; + +use base FS::part_event::Action; + +=head1 DESCRIPTION + +FS::part_event::Action is a base class for event action classes. + +=head1 METHODS + +These methods are implemented in each action class. + +=over 4 + +=item description + +Action classes must define a description method. This method should return a +scalar description of the action. + +=item eventtable_hashref + +Action classes must define a eventtable_hashref method if they can only be +triggered against some kinds of tables. This method should return a hash +reference of eventtables (values set true indicate the action can be performed): + + sub eventtable_hashref { + { 'cust_main' => 1, + 'cust_bill' => 1, + 'cust_pkg' => 0, + 'cust_pay_batch' => 0, + }; + } + +=cut + +#fallback +sub eventtable_hashref { + { 'cust_main' => 1, + 'cust_bill' => 1, + 'cust_pkg' => 1, + 'cust_pay_batch' => 1, + }; +} + +=item option_fields + +Action classes may define an option_fields method to indicate that they +accept one or more options. + +This method should return a list of option names and option descriptions. +Each option description can be a scalar description, for simple options, or a +hashref with the following values: + +=item label - Description + +=item type - Currently text, money, checkbox, checkbox-multiple, select, select-agent, select-pkg_class, select-part_referral, select-table, fixed, hidden, (others can be implemented as httemplate/elements/tr-TYPE.html mason components). Defaults to text. + +=item size - Size for text fields + +=item options - For checkbox-multiple and select, a list reference of available option values. + +=item option_labels - For select, a hash reference of availble option values and labels. + +=item value - for checkbox, fixed, hidden + +=item table - for select-table + +=item name_col - for select-table + +=item NOTE: See httemplate/elements/select-table.html for a full list of the optinal options for the select-table type + +=back + +NOTE: A database connection is B<not> yet available when this subroutine is +executed. + +Example: + + sub option_fields { + ( + 'field' => 'description', + + 'another_field' => { 'label'=>'Amount', 'type'=>'money', }, + + 'third_field' => { 'label' => 'Types', + 'type' => 'select', + 'options' => [ 'h', 's' ], + 'option_labels' => { 'h' => 'Happy', + 's' => 'Sad', + }, + ); + } + +=cut + +#fallback +sub option_fields { + (); +} + +=item default_weight + +Action classes may define a default weighting. Weights control execution order +relative to other actions (that are triggered at the same time). + +=cut + +#fallback +sub default_weight { + 100; +} + +=item deprecated + +Action classes may define a deprecated method that returns true, indicating +that this action is deprecated. + +=cut + +#default +sub deprecated { + 0; +} + +=item do_action CUSTOMER_EVENT_OBJECT + +Action classes must define an action method. This method is triggered if +all conditions have been met. + +The object which triggered the event (an FS::cust_main, FS::cust_bill or +FS::cust_pkg object) is passed as an argument. + +To retreive option values, call the option method on the desired option, i.e.: + + my( $self, $cust_object ) = @_; + $value_of_field = $self->option('field'); + +To indicate sucessful completion, simply return. Optionally, you can return a +string of information status information about the sucessful completion, or +simply return the empty string. + +To indicate a failure and that this event should retry, die with the desired +error message. + +=back + +=head1 BASE METHODS + +These methods are defined in the base class for use in action classes. + +=over 4 + +=item cust_main CUST_OBJECT + +Return the customer object (see L<FS::cust_main>) associated with the provided +object (the object itself if it is already a customer object). + +=cut + +sub cust_main { + my( $self, $cust_object ) = @_; + + $cust_object->isa('FS::cust_main') ? $cust_object : $cust_object->cust_main; + +} + +=item option_label OPTIONNAME + +Returns the label for the specified option name. + +=cut + +sub option_label { + my( $self, $optionname ) = @_; + + my %option_fields = $self->option_fields; + + ref( $option_fields{$optionname} ) + ? $option_fields{$optionname}->{'label'} + : $option_fields{$optionname} + or $optionname; +} + +=item option_fields_hashref + +Returns the option fields as an (ordered) hash reference. + +=cut + +sub option_fields_hashref { + my $self = shift; + tie my %hash, 'Tie::IxHash', $self->option_fields; +} + +=item option_fields_listref + +Returns just the option field names as a list reference. + +=cut + +sub option_fields_listref { + my $self = shift; + my $hashref = $self->option_fields_hashref; + [ keys %$hashref ]; +} + +=back + +=cut + +1; + diff --git a/FS/FS/part_event/Action/addpost.pm b/FS/FS/part_event/Action/addpost.pm new file mode 100644 index 0000000..e0e3fa8 --- /dev/null +++ b/FS/FS/part_event/Action/addpost.pm @@ -0,0 +1,24 @@ +package FS::part_event::Action::addpost; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + 'Add postal invoicing'; +} + +sub default_weight { + 20; +} + +sub do_action { + my( $self, $cust_object ) = @_; + + my $cust_main = $self->cust_main($cust_object); + + $cust_main->invoicing_list_addpost(); + + ''; +} + +1; diff --git a/FS/FS/part_event/Action/apply.pm b/FS/FS/part_event/Action/apply.pm new file mode 100644 index 0000000..f91c604 --- /dev/null +++ b/FS/FS/part_event/Action/apply.pm @@ -0,0 +1,28 @@ +package FS::part_event::Action::apply; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + 'Apply unapplied payments and credits'; +} + +sub deprecated { + 1; +} + +sub default_weight { + 70; +} + +sub do_action { + my( $self, $cust_object ) = @_; + + my $cust_main = $self->cust_main($cust_object); + + $cust_main->apply_payments_and_credits; + + ''; +} + +1; diff --git a/FS/FS/part_event/Action/bill.pm b/FS/FS/part_event/Action/bill.pm new file mode 100644 index 0000000..fec025f --- /dev/null +++ b/FS/FS/part_event/Action/bill.pm @@ -0,0 +1,30 @@ +package FS::part_event::Action::bill; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + #'Generate invoices (normally only used with a <i>Late Fee</i> event)'; + 'Generate invoices (normally only used with a Late Fee event)'; +} + +sub deprecated { + 1; +} + +sub default_weight { + 60; +} + +sub do_action { + my( $self, $cust_object ) = @_; + + my $cust_main = $self->cust_main($cust_object); + + my $error = $cust_main->bill; + die $error if $error; + + ''; +} + +1; diff --git a/FS/FS/part_event/Action/cancel.pm b/FS/FS/part_event/Action/cancel.pm new file mode 100644 index 0000000..94f3146 --- /dev/null +++ b/FS/FS/part_event/Action/cancel.pm @@ -0,0 +1,35 @@ +package FS::part_event::Action::cancel; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + 'Cancel'; +} + +sub option_fields { + ( + 'reasonnum' => { 'label' => 'Reason', + 'type' => 'select-reason', + 'reason_class' => 'C', + }, + ); + +}; + +sub default_weight { + 20; +} + +sub do_action { + my( $self, $cust_object ) = @_; + + my $cust_main = $self->cust_main($cust_object); + + my $error = $cust_main->cancel( 'reason' => $self->option('reasonnum') ); + die $error if $error; + + ''; +} + +1; diff --git a/FS/FS/part_event/Action/collect.pm b/FS/FS/part_event/Action/collect.pm new file mode 100644 index 0000000..fa94b7d --- /dev/null +++ b/FS/FS/part_event/Action/collect.pm @@ -0,0 +1,30 @@ +package FS::part_event::Action::collect; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + #'Collect on invoices (normally only used with a <i>Late Fee</i> and <i>Generate Invoice</i> events)'; + 'Collect on invoices (normally only used with a Late Fee and Generate Invoice events)'; +} + +sub deprecated { + 1; +} + +sub default_weight { + 80; +} + +sub do_action { + my( $self, $cust_object ) = @_; + + my $cust_main = $self->cust_main($cust_object); + + my $error = $cust_main->collect; + die $error if $error; + + ''; +} + +1; diff --git a/FS/FS/part_event/Action/cust_bill_batch.pm b/FS/FS/part_event/Action/cust_bill_batch.pm new file mode 100644 index 0000000..aec0925 --- /dev/null +++ b/FS/FS/part_event/Action/cust_bill_batch.pm @@ -0,0 +1,31 @@ +package FS::part_event::Action::cust_bill_batch; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + 'Add card or check to a pending batch'; +} + +sub deprecated { + 1; +} + +sub eventtable_hashref { + { 'cust_bill' => 1 }; +} + +sub default_weight { + 40; +} + +sub do_action { + my( $self, $cust_bill ) = @_; + + #my $cust_main = $self->cust_main($cust_bill); + my $cust_main = $cust_bill->cust_main; + + $cust_bill->batch_card; # ( %options ); #XXX options?? +} + +1; diff --git a/FS/FS/part_event/Action/cust_bill_comp.pm b/FS/FS/part_event/Action/cust_bill_comp.pm new file mode 100644 index 0000000..636a66d --- /dev/null +++ b/FS/FS/part_event/Action/cust_bill_comp.pm @@ -0,0 +1,34 @@ +package FS::part_event::Action::cust_bill_comp; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + 'Pay invoice with a complimentary "payment"'; +} + +sub deprecated { + 1; +} + +sub eventtable_hashref { + { 'cust_bill' => 1 }; +} + +sub default_weight { + 30; +} + +sub do_action { + my( $self, $cust_bill ) = @_; + + #my $cust_main = $self->cust_main($cust_bill); + my $cust_main = $cust_bill->cust_main; + + my $error = $cust_bill->comp; + die $error if $error; + + ''; +} + +1; diff --git a/FS/FS/part_event/Action/cust_bill_fee_percent.pm b/FS/FS/part_event/Action/cust_bill_fee_percent.pm new file mode 100644 index 0000000..100fc8b --- /dev/null +++ b/FS/FS/part_event/Action/cust_bill_fee_percent.pm @@ -0,0 +1,40 @@ +package FS::part_event::Action::cust_bill_fee_percent; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + 'Late fee (percentage of invoice)'; +} + +sub eventtable_hashref { + { 'cust_bill' => 1 }; +} + +sub option_fields { + ( + 'percent' => { label=>'Percent', size=>2, }, + 'reason' => 'Reason', + ); +} + +sub default_weight { + 10; +} + +sub do_action { + my( $self, $cust_bill ) = @_; + + #my $cust_main = $self->cust_main($cust_bill); + my $cust_main = $cust_bill->cust_main; + + my $error = $cust_main->charge( + sprintf('%.2f', $cust_bill->owed * $self->option('percent') / 100 ), + $self->option('reason') + ); + die $error if $error; + + ''; +} + +1; diff --git a/FS/FS/part_event/Action/cust_bill_realtime_card.pm b/FS/FS/part_event/Action/cust_bill_realtime_card.pm new file mode 100644 index 0000000..471c946 --- /dev/null +++ b/FS/FS/part_event/Action/cust_bill_realtime_card.pm @@ -0,0 +1,32 @@ +package FS::part_event::Action::cust_bill_realtime_card; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + #'Run card with a <a href="http://420.am/business-onlinepayment/">Business::OnlinePayment</a> realtime gateway'; + 'Run card with a Business::OnlinePayment realtime gateway'; +} + +sub deprecated { + 1; +} + +sub eventtable_hashref { + { 'cust_bill' => 1 }; +} + +sub default_weight { + 30; +} + +sub do_action { + my( $self, $cust_bill ) = @_; + + #my $cust_main = $self->cust_main($cust_bill); + my $cust_main = $cust_bill->cust_main; + + $cust_bill->realtime_card; +} + +1; diff --git a/FS/FS/part_event/Action/cust_bill_realtime_check.pm b/FS/FS/part_event/Action/cust_bill_realtime_check.pm new file mode 100644 index 0000000..9a52830 --- /dev/null +++ b/FS/FS/part_event/Action/cust_bill_realtime_check.pm @@ -0,0 +1,32 @@ +package FS::part_event::Action::cust_bill_realtime_check; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + #'Run check with a <a href="http://420.am/business-onlinepayment/">Business::OnlinePayment</a> realtime gateway'; + 'Run check with a Business::OnlinePayment realtime gateway'; +} + +sub deprecated { + 1; +} + +sub eventtable_hashref { + { 'cust_bill' => 1 }; +} + +sub default_weight { + 30; +} + +sub do_action { + my( $self, $cust_bill ) = @_; + + #my $cust_main = $self->cust_main($cust_bill); + my $cust_main = $cust_bill->cust_main; + + $cust_bill->realtime_ach; +} + +1; diff --git a/FS/FS/part_event/Action/cust_bill_realtime_lec.pm b/FS/FS/part_event/Action/cust_bill_realtime_lec.pm new file mode 100644 index 0000000..db091da --- /dev/null +++ b/FS/FS/part_event/Action/cust_bill_realtime_lec.pm @@ -0,0 +1,32 @@ +package FS::part_event::Action::cust_bill_realtime_lec; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + #'Run phone bill ("LEC") billing with a <a href="http://420.am/business-onlinepayment/">Business::OnlinePayment</a> realtime gateway'; + 'Run phone bill ("LEC") billing with a Business::OnlinePayment realtime gateway'; +} + +sub deprecated { + 1; +} + +sub eventtable_hashref { + { 'cust_bill' => 1 }; +} + +sub default_weight { + 30; +} + +sub do_action { + my( $self, $cust_bill ) = @_; + + #my $cust_main = $self->cust_main($cust_bill); + my $cust_main = $cust_bill->cust_main; + + $cust_bill->realtime_lec; +} + +1; diff --git a/FS/FS/part_event/Action/cust_bill_send.pm b/FS/FS/part_event/Action/cust_bill_send.pm new file mode 100644 index 0000000..9330c61 --- /dev/null +++ b/FS/FS/part_event/Action/cust_bill_send.pm @@ -0,0 +1,27 @@ +package FS::part_event::Action::cust_bill_send; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + 'Send invoice (email/print/fax)'; +} + +sub eventtable_hashref { + { 'cust_bill' => 1 }; +} + +sub default_weight { + 50; +} + +sub do_action { + my( $self, $cust_bill ) = @_; + + #my $cust_main = $self->cust_main($cust_bill); + my $cust_main = $cust_bill->cust_main; + + $cust_bill->send; +} + +1; diff --git a/FS/FS/part_event/Action/cust_bill_send_agent.pm b/FS/FS/part_event/Action/cust_bill_send_agent.pm new file mode 100644 index 0000000..fcf0007 --- /dev/null +++ b/FS/FS/part_event/Action/cust_bill_send_agent.pm @@ -0,0 +1,44 @@ +package FS::part_event::Action::cust_bill_send_agent; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + 'Send invoice (email/print/fax) with alternate template, for specific agents'; +} + +sub eventtable_hashref { + { 'cust_bill' => 1 }; +} + +sub option_fields { + ( + 'agentnum' => { label => 'Only for agent(s)', + type => 'select-agent', + multiple => 1 + }, + 'agent_templatename' => { label => 'Template', + type => 'select-invoice_template', + }, + 'agent_invoice_from' => 'Invoice email From: address', + ); +} + +sub default_weight { + 50; +} + +sub do_action { + my( $self, $cust_bill ) = @_; + + #my $cust_main = $self->cust_main($cust_bill); + my $cust_main = $cust_bill->cust_main; + + $cust_bill->send( + $self->option('agent_templatename'), + [ split(/\s*,\s*/, $self->option('agentnum') ) ], + $self->option('agent_invoice_from'), + ); +} + +1; diff --git a/FS/FS/part_event/Action/cust_bill_send_alternate.pm b/FS/FS/part_event/Action/cust_bill_send_alternate.pm new file mode 100644 index 0000000..6afb89a --- /dev/null +++ b/FS/FS/part_event/Action/cust_bill_send_alternate.pm @@ -0,0 +1,35 @@ +package FS::part_event::Action::cust_bill_send_alternate; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + 'Send invoice (email/print/fax) with alternate template'; +} + +sub eventtable_hashref { + { 'cust_bill' => 1 }; +} + +sub option_fields { + ( + 'templatename' => { label => 'Template', + type => 'select-invoice_template', + }, + ); +} + +sub default_weight { + 50; +} + +sub do_action { + my( $self, $cust_bill ) = @_; + + #my $cust_main = $self->cust_main($cust_bill); + my $cust_main = $cust_bill->cust_main; + + $cust_bill->send( $self->option('templatename') ); +} + +1; diff --git a/FS/FS/part_event/Action/cust_bill_send_csv_ftp.pm b/FS/FS/part_event/Action/cust_bill_send_csv_ftp.pm new file mode 100644 index 0000000..db3554e --- /dev/null +++ b/FS/FS/part_event/Action/cust_bill_send_csv_ftp.pm @@ -0,0 +1,56 @@ +package FS::part_event::Action::cust_bill_send_csv_ftp; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + 'Upload CSV invoice data to an FTP server'; +} + +sub deprecated { + 1; +} + +sub eventtable_hashref { + { 'cust_bill' => 1 }; +} + +sub option_fields { + ( + 'ftpformat' => { label => 'Format', + type =>'select', + options => ['default', 'billco'], + option_labels => { 'default' => 'Default', + 'billco' => 'Billco', + }, + }, + 'ftpserver' => 'FTP server', + 'ftpusername' => 'FTP username', + 'ftppassword' => 'FTP password', + 'ftpdir' => 'FTP directory', + ); +} + +sub default_weight { + 50; +} + +sub do_action { + my( $self, $cust_bill ) = @_; + + #my $cust_main = $self->cust_main($cust_bill); + my $cust_main = $cust_bill->cust_main; + + $cust_bill->send_csv( + 'protocol' => 'ftp', + 'server' => $self->option('ftpserver'), + 'username' => $self->option('ftpusername'), + 'password' => $self->option('ftppassword'), + 'dir' => $self->option('ftpdir'), + 'format' => $self->option('ftpformat'), + ); + + ''; +} + +1; diff --git a/FS/FS/part_event/Action/cust_bill_send_if_newest.pm b/FS/FS/part_event/Action/cust_bill_send_if_newest.pm new file mode 100644 index 0000000..916983e --- /dev/null +++ b/FS/FS/part_event/Action/cust_bill_send_if_newest.pm @@ -0,0 +1,40 @@ +package FS::part_event::Action::cust_bill_send_if_newest; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + 'Send invoice (email/print/fax) with alternate template, if it is still the newest invoice (useful for late notices - set to 31 days or later)'; +} + +# XXX is this handled better by something against customers?? +#sub deprecated { +# 1; +#} + +sub eventtable_hashref { + { 'cust_bill' => 1 }; +} + +sub option_fields { + ( + 'if_newest_templatename' => { label => 'Template', + type => 'select-invoice_template', + }, + ); +} + +sub default_weight { + 50; +} + +sub do_action { + my( $self, $cust_bill ) = @_; + + #my $cust_main = $self->cust_main($cust_bill); + my $cust_main = $cust_bill->cust_main; + + $cust_bill->send( $self->option('templatename') ); +} + +1; diff --git a/FS/FS/part_event/Action/cust_bill_spool_csv.pm b/FS/FS/part_event/Action/cust_bill_spool_csv.pm new file mode 100644 index 0000000..4300b61 --- /dev/null +++ b/FS/FS/part_event/Action/cust_bill_spool_csv.pm @@ -0,0 +1,64 @@ +package FS::part_event::Action::cust_bill_spool_csv; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + 'Spool CSV invoice data'; +} + +sub deprecated { + 1; +} + +sub eventtable_hashref { + { 'cust_bill' => 1 }; +} + +sub option_fields { + ( + 'spoolformat' => { label => 'Format', + type => 'select', + options => ['default', 'billco'], + option_labels => { 'default' => 'Default', + 'billco' => 'Billco', + }, + }, + 'spooldest' => { label => 'For destination', + type => 'select', + options => [ '', qw( POST EMAIL FAX ) ], + option_labels => { '' => '(all)', + 'POST' => 'Postal Mail', + 'EMAIL' => 'Email', + 'FAX' => 'Fax', + }, + }, + 'spoolbalanceover' => { label => + 'If balance (this invoice and previous) over', + type => 'money', + }, + 'spoolagent_spools' => { label => 'Individual per-agent spools', + type => 'checkbox', + }, + ); +} + +sub default_weight { + 50; +} + +sub do_action { + my( $self, $cust_bill ) = @_; + + #my $cust_main = $self->cust_main($cust_bill); + my $cust_main = $cust_bill->cust_main; + + $cust_bill->spool_csv( + 'format' => $self->option('spoolformat'), + 'dest' => $self->option('spooldest'), + 'balanceover' => $self->option('spoolbalanceover'), + 'agent_spools' => $self->option('spoolagent_spools'), + ); +} + +1; diff --git a/FS/FS/part_event/Action/cust_bill_suspend_if_balance.pm b/FS/FS/part_event/Action/cust_bill_suspend_if_balance.pm new file mode 100644 index 0000000..6559949 --- /dev/null +++ b/FS/FS/part_event/Action/cust_bill_suspend_if_balance.pm @@ -0,0 +1,48 @@ +package FS::part_event::Action::cust_bill_suspend_if_balance; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + 'Suspend if balance (this invoice and previous) over'; +} + +sub deprecated { + 1; +} + +sub eventtable_hashref { + { 'cust_bill' => 1 }; +} + +sub option_fields { + ( + 'balanceover' => { label=>'Balance over', type=>'money', }, # size=>7 }, + 'reasonnum' => { 'label' => 'Reason', + 'type' => 'select-reason', + 'reason_class' => 'S', + }, + ); +}; + +sub default_weight { + 10; +} + +sub do_action { + my( $self, $cust_bill ) = @_; + + #my $cust_main = $self->cust_main($cust_bill); + my $cust_main = $cust_bill->cust_main; + + my @err = $cust_bill->cust_suspend_if_balance_over( + $self->option('balanceover'), + 'reason' => $self->option('reasonnum'), + ); + + die join(' / ', @err) if scalar(@err); + + ''; +} + +1; diff --git a/FS/FS/part_event/Action/fee.pm b/FS/FS/part_event/Action/fee.pm new file mode 100644 index 0000000..81a8449 --- /dev/null +++ b/FS/FS/part_event/Action/fee.pm @@ -0,0 +1,33 @@ +package FS::part_event::Action::fee; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + 'Late fee (flat)'; +} + +sub option_fields { + ( + 'charge' => { label=>'Amount', type=>'money', }, # size=>7, }, + 'reason' => 'Reason', + ); +}; + +sub default_weight { + 10; +} + +sub do_action { + my( $self, $cust_object ) = @_; + + my $cust_main = $self->cust_main($cust_object); + + my $error = $cust_main->charge( $self->option('charge'), $self->option('reason') ); + + die $error if $error; + + ''; +} + +1; diff --git a/FS/FS/part_event/Action/suspend.pm b/FS/FS/part_event/Action/suspend.pm new file mode 100644 index 0000000..ec440ff --- /dev/null +++ b/FS/FS/part_event/Action/suspend.pm @@ -0,0 +1,36 @@ +package FS::part_event::Action::suspend; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + 'Suspend'; +} + +sub option_fields { + ( + 'reasonnum' => { 'label' => 'Reason', + 'type' => 'select-reason', + 'reason_class' => 'S', + }, + ); +}; + +sub default_weight { + 10; +} + +sub do_action { + my( $self, $cust_object ) = @_; + + my $cust_main = $self->cust_main($cust_object); + + my @err = $cust_main->suspend( 'reason' => $self->option('reasonnum') ); + + die join(' / ', @err) if scalar(@err); + + ''; + +} + +1; diff --git a/FS/FS/part_event/Action/suspend_if_pkgpart.pm b/FS/FS/part_event/Action/suspend_if_pkgpart.pm new file mode 100644 index 0000000..9bdc9be --- /dev/null +++ b/FS/FS/part_event/Action/suspend_if_pkgpart.pm @@ -0,0 +1,42 @@ +package FS::part_event::Action::suspend_if_pkgpart; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + 'Suspend packages'; +} + +sub option_fields { + ( + 'if_pkgpart' => { 'label' => 'Suspend packages:', + 'type' => 'select-part_pkg', + 'multiple' => 1, + }, + 'reasonnum' => { 'label' => 'Reason', + 'type' => 'select-reason', + 'reason_class' => 'S', + }, + ); +}; + +sub default_weight { + 10; +} + +sub do_action { + my( $self, $cust_object ) = @_; + + my $cust_main = $self->cust_main($cust_object); + + my @err = $cust_main->suspend_if_pkgpart( { + 'pkgparts' => [ split(/\s*,\s*/, $self->option('if_pkgpart') ) ], + 'reason' => $self->option('reasonnum'), + } ); + + die join(' / ', @err) if scalar(@err); + + ''; +} + +1; diff --git a/FS/FS/part_event/Action/suspend_unless_pkgpart.pm b/FS/FS/part_event/Action/suspend_unless_pkgpart.pm new file mode 100644 index 0000000..f9bf1e8 --- /dev/null +++ b/FS/FS/part_event/Action/suspend_unless_pkgpart.pm @@ -0,0 +1,42 @@ +package FS::part_event::Action::suspend_unless_pkgpart; + +use strict; +use base qw( FS::part_event::Action ); + +sub description { + 'Suspend packages except'; +} + +sub option_fields { + ( + 'unless_pkgpart' => { 'label' => 'Suspend packages except:', + 'type' => 'select-part_pkg', + 'multiple' => 1, + }, + 'reasonnum' => { 'label' => 'Reason', + 'type' => 'select-reason', + 'reason_class' => 'S', + }, + ); +}; + +sub default_weight { + 10; +} + +sub do_action { + my( $self, $cust_object ) = @_; + + my $cust_main = $self->cust_main($cust_object); + + my @err = $cust_main->suspend_unless_pkgpart( { + 'pkgparts' => [ split(/\s*,\s*/, $self->option('unless_pkgpart') ) ], + 'reason' => $self->option('reasonnum'), + } ); + + die join(' / ', @err) if scalar(@err); + + ''; +} + +1; diff --git a/FS/FS/part_event/Condition.pm b/FS/FS/part_event/Condition.pm new file mode 100644 index 0000000..268b9e6 --- /dev/null +++ b/FS/FS/part_event/Condition.pm @@ -0,0 +1,268 @@ +package FS::part_event::Condition; + +use strict; +use base qw( FS::part_event_condition ); + +=head1 NAME + +FS::part_event::Condition - Base class for event conditions + +=head1 SYNOPSIS + +package FS::part_event::Condition::mycondition; + +use base FS::part_event::Condition; + +=head1 DESCRIPTION + +FS::part_event::Condition is a base class for event conditions classes. + +=head1 METHODS + +These methods are implemented in each condition class. + +=over 4 + +=item description + +Condition classes must define a description method. This method should return +a scalar description of the condition. + +=item eventtable_hashref + +Condition classes must define an eventtable_hashref method if they can only be +tested against some kinds of tables. This method should return a hash reference +of eventtables (values set true indicate the condition can be tested): + + sub eventtable_hashref { + { 'cust_main' => 1, + 'cust_bill' => 1, + 'cust_pkg' => 0, + 'cust_pay_batch' => 0, + }; + } + +=cut + +#fallback +sub eventtable_hashref { + { 'cust_main' => 1, + 'cust_bill' => 1, + 'cust_pkg' => 1, + 'cust_pay_batch' => 1, + }; +} + +=item option_fields + +Condition classes may define an option_fields method to indicate that they +accept one or more options. + +This method should return a list of option names and option descriptions. +Each option description can be a scalar description, for simple options, or a +hashref with the following values: + +=over 4 + +=item label - Description + +=item type - Currently text, money, checkbox, checkbox-multiple, select, select-agent, select-pkg_class, select-part_referral, select-table, fixed, hidden, (others can be implemented as httemplate/elements/tr-TYPE.html mason components). Defaults to text. + +=item options - For checkbox-multiple and select, a list reference of available option values. + +=item option_labels - For checkbox-multiple (and select?), a hash reference of availble option values and labels. + +=item value - for checkbox, fixed, hidden (also a default for text, money, more?) + +=item table - for select-table + +=item name_col - for select-table + +=item NOTE: See httemplate/elements/select-table.html for a full list of the optinal options for the select-table type + +=back + +NOTE: A database connection is B<not> yet available when this subroutine is +executed. + +Example: + + sub option_fields { + ( + 'field' => 'description', + + 'another_field' => { 'label'=>'Amount', 'type'=>'money', }, + + 'third_field' => { 'label' => 'Types', + 'type' => 'checkbox-multiple', + 'options' => [ 'h', 's' ], + 'option_labels' => { 'h' => 'Happy', + 's' => 'Sad', + }, + ); + } + +=cut + +#fallback +sub option_fields { + (); +} + +=item condition CUSTOMER_EVENT_OBJECT + +Condition classes must define a condition method. This method is evaluated +to determine if the condition has been met. The object which triggered the +event (an FS::cust_main, FS::cust_bill or FS::cust_pkg object) is passed as +the first argument. Additional arguments are list of key-value pairs. + +To retreive option values, call the option method on the desired option, i.e.: + + my( $self, $cust_object, %opts ) = @_; + $value_of_field = $self->option('field'); + +Available additional arguments: + + $time = $opt{'time'}; #use this instead of time or $^T + +Return a true value if the condition has been met, and a false value if it has +not. + +=item condition_sql EVENTTABLE + +Condition classes may optionally define a condition_sql method. This B<class> +method should return an SQL fragment that tests for this condition. The +fragment is evaluated and a true value of this expression indicates that the +condition has been met. The event table (cust_main, cust_bill or cust_pkg) is +passed as an argument. + +This method is used for optimizing event queries. You may want to add indices +for any columns referenced. It is acceptable to return an SQL fragment which +partially tests the condition; doing so will still reduce the number of +records which much be returned and tested with the B<condition> method. + +=cut + +# fallback. +sub condition_sql { + my( $class, $eventtable ) = @_; + #... + 'true'; +} + +=item implicit_flag + +This is used internally by the I<once> and I<balance> conditions. You probably +do B<not> want to define this method for new custom conditions, unless you're +sure you want B<every> new action to start with your condition. + +Condition classes may define an implicit_flag method that returns true to +indicate that all new events should start with this condition. (Currently, +condition classes which do so should be applicable to all kinds of +I<eventtable>s.) The numeric value of the flag also defines the ordering of +implicit conditions. + +=cut + +#fallback +sub implicit_flag { 0; } + +=item remove_warning + +Again, used internally by the I<once> and I<balance> conditions; probably not +a good idea for new custom conditions. + +Condition classes may define a remove_warning method containing a string +warning message to enable a confirmation dialog triggered when the condition +is removed from an event. + +=cut + +#fallback +sub remove_warning { ''; } + +=item order_sql + +This is used internally by the I<balance_age> and I<cust_bill_age> conditions +to declare ordering; probably not of general use for new custom conditions. + +=item order_sql_weight + +In conjunction with order_sql, this defines which order the ordering fragments +supplied by different B<order_sql> should be used. + +=cut + +sub order_sql_weight { ''; } + +=back + +=head1 BASE METHODS + +These methods are defined in the base class for use in condition classes. + +=over 4 + +=item cust_main CUST_OBJECT + +Return the customer object (see L<FS::cust_main>) associated with the provided +object (the object itself if it is already a customer object). + +=cut + +sub cust_main { + my( $self, $cust_object ) = @_; + + $cust_object->isa('FS::cust_main') ? $cust_object : $cust_object->cust_main; + +} + +=item option_label OPTIONNAME + +Returns the label for the specified option name. + +=cut + +sub option_label { + my( $self, $optionname ) = @_; + + my %option_fields = $self->option_fields; + + ref( $option_fields{$optionname} ) + ? $option_fields{$optionname}->{'label'} + : $option_fields{$optionname} + or $optionname; +} + +=back + +=item condition_sql_option + +This is a class method that returns an SQL fragment for retreiving a condition +option. It is primarily intended for use in B<condition_sql>. +=cut + +sub condition_sql_option { + my( $class, $option ) = @_; + + ( my $condname = $class ) =~ s/^.*:://; + + "( SELECT optionvalue FROM part_event_condition_option + WHERE part_event_condition_option.eventconditionnum = + cond_$condname.eventconditionnum + AND part_event_condition_option.optionname = '$option' + )"; +} + + +=head1 NEW CONDITION CLASSES + +A module should be added in FS/FS/part_event/Condition/ which implements the +methods desribed above in L</METHODS>. An example may be found in the +eg/part_event-Condition-template.pm file. + +=cut + +1; + + diff --git a/FS/FS/part_event/Condition/agent.pm b/FS/FS/part_event/Condition/agent.pm new file mode 100644 index 0000000..da428c1 --- /dev/null +++ b/FS/FS/part_event/Condition/agent.pm @@ -0,0 +1,37 @@ +package FS::part_event::Condition::agent; + +use strict; + +use base qw( FS::part_event::Condition ); + +# see the FS::part_event::Condition manpage for full documentation on each +# of the required and optional methods. + +sub description { + 'Agent'; +} + +sub option_fields { + ( + 'agentnum' => { label=>'Agent', type=>'select-agent', }, + ); +} + +sub condition { + my($self, $object, %opt) = @_; + + my $cust_main = $self->cust_main($object); + + my $agentnum = $self->option('agentnum'); + + $cust_main->agentnum == $agentnum; + +} + +#sub condition_sql { +# my( $self, $table ) = @_; +# +# 'true'; +#} + +1; diff --git a/FS/FS/part_event/Condition/agent_type.pm b/FS/FS/part_event/Condition/agent_type.pm new file mode 100644 index 0000000..54c8932 --- /dev/null +++ b/FS/FS/part_event/Condition/agent_type.pm @@ -0,0 +1,40 @@ +package FS::part_event::Condition::agent_type; + +use strict; + +use base qw( FS::part_event::Condition ); + +# see the FS::part_event::Condition manpage for full documentation on each +# of the required and optional methods. + +sub description { + 'Agent Type'; +} + +sub option_fields { + ( + 'typenum' => { label => 'Agent Type', + type => 'select-agent_type', + disable_empty => 1, + }, + ); +} + +sub condition { + my($self, $object, %opt) = @_; + + my $cust_main = $self->cust_main($object); + + my $typenum = $self->option('typenum'); + + $cust_main->agent->typenum == $typenum; + +} + +#sub condition_sql { +# my( $self, $table ) = @_; +# +# 'true'; +#} + +1; diff --git a/FS/FS/part_event/Condition/balance.pm b/FS/FS/part_event/Condition/balance.pm new file mode 100644 index 0000000..2639413 --- /dev/null +++ b/FS/FS/part_event/Condition/balance.pm @@ -0,0 +1,48 @@ +package FS::part_event::Condition::balance; + +use strict; +use FS::cust_main; + +use base qw( FS::part_event::Condition ); + +sub description { 'Customer balance'; } + +sub implicit_flag { 20; } + +sub remove_warning { + 'Are you sure you want to remove this condition? Doing so will allow this event to run even if the customer has no outstanding balance. Perhaps you want to reset "Balance over" to 0 instead of removing the condition entirely?'; #better error msg? +} + +sub option_fields { + ( + 'balance' => { 'label' => 'Balance over', + 'type' => 'money', + 'value' => '0.00', #default + }, + ); +} + +sub condition { + my($self, $object) = @_; + + my $cust_main = $self->cust_main($object); + + my $over = $self->option('balance'); + $over = 0 unless length($over); + + $cust_main->balance > $over; +} + +sub condition_sql { + my( $class, $table ) = @_; + + my $over = $class->condition_sql_option('balance'); + + my $balance_sql = FS::cust_main->balance_sql; + + "$balance_sql > $over"; + +} + +1; + diff --git a/FS/FS/part_event/Condition/balance_age.pm b/FS/FS/part_event/Condition/balance_age.pm new file mode 100644 index 0000000..94f231e --- /dev/null +++ b/FS/FS/part_event/Condition/balance_age.pm @@ -0,0 +1,83 @@ +package FS::part_event::Condition::balance_age; + +require 5.006; +use strict; +use Time::Local qw(timelocal_nocheck); + +use base qw( FS::part_event::Condition ); + +sub description { 'Customer balance age'; } + +sub option_fields { + ( + 'balance' => { 'label' => 'Balance over', + 'type' => 'money', + 'value' => '0.00', #default + }, + 'age' => { 'label' => 'Age', + 'type' => 'freq', + }, + ); +} + +sub condition { + my($self, $object, %opt) = @_; + + my $cust_main = $self->cust_main($object); + + my $over = $self->option('balance'); + $over = 0 unless length($over); + + #false laziness w/cust_bill_age + my $time = $opt{'time'}; + my $age = $self->option('age'); + $age = '0m' unless length($age); + + my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($time) )[0,1,2,3,4,5]; + if ( $age =~ /^(\d+)m$/i ) { + $mon -= $1; + until ( $mon >= 0 ) { $mon += 12; $year--; } + } elsif ( $age =~ /^(\d+)y$/i ) { + $year -= $1; + } elsif ( $age =~ /^(\d+)w$/i ) { + $mday -= $1 * 7; + } elsif ( $age =~ /^(\d+)d$/i ) { + $mday -= $1; + } elsif ( $age =~ /^(\d+)h$/i ) { + $hour -= $hour; + } else { + die "unparsable age: $age"; + } + my $age_date = timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year); + + $cust_main->balance_date($age_date) > $over; +} + +sub condition_sql { + my( $class, $table, %opt ) = @_; + + my $time = $opt{'time'}; + + my $over = $class->condition_sql_option('balance'); + my $age = $class->condition_sql_option('age'); + my $age_sql = + "$time - EXTRACT( EPOCH FROM REPLACE( $age, 'm', 'mon')::interval )"; + + my $balance_sql = FS::cust_main->balance_date_sql( $age_sql ); + + "$balance_sql > $over"; + +} + +sub order_sql { + my( $class ) = @_; + + my $age = $class->condition_sql_option('age'); + "EXTRACT( EPOCH FROM REPLACE( $age, 'm', 'mon')::interval )"; +} + +sub order_sql_weight { + 10; +} + +1; diff --git a/FS/FS/part_event/Condition/balance_under.pm b/FS/FS/part_event/Condition/balance_under.pm new file mode 100644 index 0000000..5e19034 --- /dev/null +++ b/FS/FS/part_event/Condition/balance_under.pm @@ -0,0 +1,42 @@ +package FS::part_event::Condition::balance_under; + +use strict; +use FS::cust_main; + +use base qw( FS::part_event::Condition ); + +sub description { 'Customer balance (under)'; } + +sub option_fields { + ( + 'balance' => { 'label' => 'Balance under (or equal to)', + 'type' => 'money', + 'value' => '0.00', #default + }, + ); +} + +sub condition { + my($self, $object) = @_; + + my $cust_main = $self->cust_main($object); + + my $under = $self->option('balance'); + $under = 0 unless length($under); + + $cust_main->balance <= $under; +} + +sub condition_sql { + my( $class, $table ) = @_; + + my $under = $class->condition_sql_option('balance'); + + my $balance_sql = FS::cust_main->balance_sql; + + "$balance_sql <= $under"; + +} + +1; + diff --git a/FS/FS/part_event/Condition/cust_bill_age.pm b/FS/FS/part_event/Condition/cust_bill_age.pm new file mode 100644 index 0000000..9af6bdd --- /dev/null +++ b/FS/FS/part_event/Condition/cust_bill_age.pm @@ -0,0 +1,83 @@ +package FS::part_event::Condition::cust_bill_age; + +require 5.006; +use strict; +use Time::Local qw(timelocal_nocheck); + +use base qw( FS::part_event::Condition ); + +sub description { + 'Invoice age'; +} + +sub eventtable_hashref { + { 'cust_main' => 0, + 'cust_bill' => 1, + 'cust_pkg' => 0, + }; +} + +#something like this +sub option_fields { + ( + #'days' => { label=>'Days', size=>3, }, + 'age' => { label=>'Age', type=>'freq', }, + ); +} + +sub condition { + my( $self, $cust_bill, %opt ) = @_; + + #false laziness w/balance_age + my $time = $opt{'time'}; + my $age = $self->option('age'); + $age = '0m' unless length($age); + + my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($time) )[0,1,2,3,4,5]; + if ( $age =~ /^(\d+)m$/i ) { + $mon -= $1; + until ( $mon >= 0 ) { $mon += 12; $year--; } + } elsif ( $age =~ /^(\d+)y$/i ) { + $year -= $1; + } elsif ( $age =~ /^(\d+)w$/i ) { + $mday -= $1 * 7; + } elsif ( $age =~ /^(\d+)d$/i ) { + $mday -= $1; + } elsif ( $age =~ /^(\d+)h$/i ) { + $hour -= $hour; + } else { + die "unparsable age: $age"; + } + my $age_date = timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year); + + $cust_bill->_date <= $age_date; + +} + +# and seconds <= $time - cust_bill._date + +sub condition_sql { + my( $class, $table, %opt ) = @_; + + my $time = $opt{'time'}; + + my $age = $class->condition_sql_option('age'); + my $age_sql = + "$time - EXTRACT( EPOCH FROM REPLACE( $age, 'm', 'mon')::interval )"; + + "cust_bill._date <= $age_sql"; + +} + +sub order_sql { + my( $class ) = @_; + + my $age = $class->condition_sql_option('age'); + "EXTRACT( EPOCH FROM REPLACE( $age, 'm', 'mon')::interval )"; +} + +sub order_sql_weight { + 0; +} + +1; diff --git a/FS/FS/part_event/Condition/cust_bill_owed.pm b/FS/FS/part_event/Condition/cust_bill_owed.pm new file mode 100644 index 0000000..e90d3db --- /dev/null +++ b/FS/FS/part_event/Condition/cust_bill_owed.pm @@ -0,0 +1,48 @@ +package FS::part_event::Condition::cust_bill_owed; + +use strict; +use FS::cust_bill; + +use base qw( FS::part_event::Condition ); + +sub description { + 'Amount owed on specific invoice'; +} + +sub eventtable_hashref { + { 'cust_main' => 0, + 'cust_bill' => 1, + 'cust_pkg' => 0, + }; +} + +sub option_fields { + ( + 'owed' => { 'label' => 'Amount owed over', + 'type' => 'money', + 'value' => '0.00', #default + }, + ); +} + +sub condition { + #my($self, $cust_bill, %opt) = @_; + my($self, $cust_bill) = @_; + + my $over = $self->option('owed'); + $over = 0 unless length($over); + + $cust_bill->owed > $over; +} + +sub condition_sql { + my( $class, $table ) = @_; + + my $over = $class->condition_sql_option('owed'); + + my $owed_sql = FS::cust_bill->owed_sql; + + "$owed_sql > $over"; +} + +1; diff --git a/FS/FS/part_event/Condition/cust_bill_owed_under.pm b/FS/FS/part_event/Condition/cust_bill_owed_under.pm new file mode 100644 index 0000000..460e6a4 --- /dev/null +++ b/FS/FS/part_event/Condition/cust_bill_owed_under.pm @@ -0,0 +1,49 @@ +package FS::part_event::Condition::cust_bill_owed_under; + +use strict; +use FS::cust_bill; + +use base qw( FS::part_event::Condition ); + +sub description { + 'Amount owed on specific invoice (under)'; +} + +sub eventtable_hashref { + { 'cust_main' => 0, + 'cust_bill' => 1, + 'cust_pkg' => 0, + }; +} + +sub option_fields { + ( + 'owed' => { 'label' => 'Amount owed under (or equal to)', + 'type' => 'money', + 'value' => '0.00', #default + }, + ); +} + +sub condition { + #my($self, $cust_bill, %opt) = @_; + my($self, $cust_bill) = @_; + + my $under = $self->option('owed'); + $under = 0 unless length($under); + + $cust_bill->owed <= $under; + +} + +sub condition_sql { + my( $class, $table ) = @_; + + my $under = $class->condition_sql_option('owed'); + + my $owed_sql = FS::cust_bill->owed_sql; + + "$owed_sql <= $under"; +} + +1; diff --git a/FS/FS/part_event/Condition/cust_pay_batch_declined.pm b/FS/FS/part_event/Condition/cust_pay_batch_declined.pm new file mode 100644 index 0000000..b3a8d70 --- /dev/null +++ b/FS/FS/part_event/Condition/cust_pay_batch_declined.pm @@ -0,0 +1,51 @@ +package FS::part_event::Condition::cust_pay_batch_declined; + +use strict; + +use base qw( FS::part_event::Condition ); + +sub description { + 'Batch payment declined'; +} + +sub eventtable_hashref { + { 'cust_main' => 0, + 'cust_bill' => 0, + 'cust_pkg' => 0, + 'cust_pay_batch' => 1, + }; +} + +#sub option_fields { +# ( +# 'field' => 'description', +# +# 'another_field' => { 'label'=>'Amount', 'type'=>'money', }, +# +# 'third_field' => { 'label' => 'Types', +# 'type' => 'checkbox-multiple', +# 'options' => [ 'h', 's' ], +# 'option_labels' => { 'h' => 'Happy', +# 's' => 'Sad', +# }, +# ); +#} + +sub condition { + my($self, $cust_pay_batch, %opt) = @_; + + #my $cust_main = $self->cust_main($object); + #my $value_of_field = $self->option('field'); + #my $time = $opt{'time'}; #use this instead of time or $^T + + $cust_pay_batch->status =~ /Declined/i; + +} + +#sub condition_sql { +# my( $class, $table ) = @_; +# #... +# 'true'; +#} + +1; diff --git a/FS/FS/part_event/Condition/cust_status.pm b/FS/FS/part_event/Condition/cust_status.pm new file mode 100644 index 0000000..fbdff25 --- /dev/null +++ b/FS/FS/part_event/Condition/cust_status.pm @@ -0,0 +1,32 @@ +package FS::part_event::Condition::cust_status; + +use strict; + +use base qw( FS::part_event::Condition ); +use FS::Record qw( qsearch ); + +sub description { + 'Customer Status'; +} + +#something like this +sub option_fields { + ( + 'status' => { 'label' => 'Customer Status', + 'type' => 'select-cust_main-status', + 'multiple' => 1, + }, + ); +} + +sub condition { + my( $self, $object) = @_; + + my $cust_main = $self->cust_main($object); + + #XXX test + my $hashref = $self->option('status') || {}; + $hashref->{ $cust_main->status }; +} + +1; diff --git a/FS/FS/part_event/Condition/every.pm b/FS/FS/part_event/Condition/every.pm new file mode 100644 index 0000000..3408b0a --- /dev/null +++ b/FS/FS/part_event/Condition/every.pm @@ -0,0 +1,67 @@ +package FS::part_event::Condition::every; + +use strict; +use FS::UID qw( dbh ); +use FS::Record qw( qsearch ); +use FS::cust_event; + +use base qw( FS::part_event::Condition ); + +sub description { "Don't retry failures more often than specified interval"; } + +sub option_fields { + ( + 'retry_delay' => { label=>'Retry after', type=>'freq', value=>'1d', }, + 'max_tries' => { label=>'Maximum # of attempts', type=>'text', size=>3, }, + ); +} + +my %after = ( + 'h' => 3600, + 'd' => 86400, + 'w' => 604800, + 'm' => 2592000, #well, 30 days... presumably people would mostly use d or w + '' => 2592000, + 'y' => 31536000, #well, 365 days... +); + +my $sql = + "SELECT COUNT(*) FROM cust_event WHERE eventpart = ? AND tablenum = ?"; + +sub condition { + my($self, $object, %opt) = @_; + + my $obj_pkey = $object->primary_key; + my $tablenum = $object->$obj_pkey(); + + if ( $self->option('max_tries') =~ /^\s*(\d+)\s*$/ ) { + my $max_tries = $1; + my $sth = dbh->prepare($sql) + or die dbh->errstr. " preparing: $sql"; + $sth->execute($self->eventpart, $tablenum) + or die $sth->errstr. " executing: $sql"; + my $tries = $sth->fetchrow_arrayref->[0]; + return 0 if $tries >= $max_tries; + } + + my $time = $opt{'time'}; + my $retry_delay = $self->option('retry_delay'); + $retry_delay =~ /^(\d+)([hdwmy]?)$/ + or die "unparsable retry_delay: $retry_delay"; + my $date_after = $time - $1 * $after{$2}; + + my $sth = dbh->prepare("$sql AND date > ?") # AND status = 'failed' " + or die dbh->errstr. " preparing: $sql"; + $sth->execute($self->eventpart, $tablenum, $date_after) + or die $sth->errstr. " executing: $sql"; + ! $sth->fetchrow_arrayref->[0]; + +} + +#sub condition_sql { +# my( $self, $table ) = @_; +# +# 'true'; +#} + +1; diff --git a/FS/FS/part_event/Condition/once.pm b/FS/FS/part_event/Condition/once.pm new file mode 100644 index 0000000..8c24e83 --- /dev/null +++ b/FS/FS/part_event/Condition/once.pm @@ -0,0 +1,48 @@ +package FS::part_event::Condition::once; + +use strict; +use FS::Record qw( qsearch ); +use FS::part_event; +use FS::cust_event; + +use base qw( FS::part_event::Condition ); + +sub description { "Don't run this event again after it has completed sucessfully"; } + +sub implicit_flag { 10; } + +sub remove_warning { + 'Are you sure you want to remove this condition? Doing so will allow this event to run every time the other conditions are satisfied, even if it has already run sucessfully.'; #better error msg? +} + +sub condition { + my($self, $object) = @_; + + my $obj_pkey = $object->primary_key; + my $tablenum = $object->$obj_pkey(); + + my @existing = qsearch( 'cust_event', { + 'eventpart' => $self->eventpart, + 'tablenum' => $tablenum, + 'status' => { op=>'!=', value=>'failed' }, + } ); + + ! scalar(@existing); + +} + +sub condition_sql { + my( $self, $table ) = @_; + + my %tablenum = %{ FS::part_event->eventtable_pkey_sql }; + + "0 = ( SELECT COUNT(*) FROM cust_event + WHERE cust_event.eventpart = part_event.eventpart + AND cust_event.tablenum = $tablenum{$table} + AND status != 'failed' + ) + "; + +} + +1; diff --git a/FS/FS/part_event/Condition/payby.pm b/FS/FS/part_event/Condition/payby.pm new file mode 100644 index 0000000..d931568 --- /dev/null +++ b/FS/FS/part_event/Condition/payby.pm @@ -0,0 +1,50 @@ +package FS::part_event::Condition::payby; + +use strict; +use Tie::IxHash; +use FS::payby; + +use base qw( FS::part_event::Condition ); + +sub description { + #'customer payment types: '; + 'Customer payment type'; +} + +#something like this +tie my %payby, 'Tie::IxHash', FS::payby->cust_payby2longname; +sub option_fields { + ( + 'payby' => { + label => 'Customer payment type', + #type => 'select-multiple', + type => 'checkbox-multiple', + options => [ keys %payby ], + option_labels => \%payby, + }, + ); +} + +sub condition { + my( $self, $object ) = @_; + + my $cust_main = $self->cust_main($object); + + #uuh.. all right? test this. + my $hashref = $self->option('payby') || {}; + $hashref->{ $cust_main->payby }; + +} + +#sub condition_sql { +# my( $self, $table ) = @_; +# +# #uuh... yeah... something like this. test it for sure. +# +# my @payby = keys %{ $self->option('payby') }; +# +# ' ( '. join(' OR ', map { "cust_main.payby = '$_'" } @payby ). ' ) '; +# +#} + +1; diff --git a/FS/FS/part_event/Condition/pkg_class.pm b/FS/FS/part_event/Condition/pkg_class.pm new file mode 100644 index 0000000..8c9031c --- /dev/null +++ b/FS/FS/part_event/Condition/pkg_class.pm @@ -0,0 +1,38 @@ +package FS::part_event::Condition::pkg_class; + +use strict; + +use base qw( FS::part_event::Condition ); +use FS::Record qw( qsearch ); +use FS::pkg_class; + +sub description { + 'Package Class'; +} + +sub eventtable_hashref { + { 'cust_main' => 0, + 'cust_bill' => 0, + 'cust_pkg' => 1, + }; +} + +#something like this +sub option_fields { + ( + 'pkgclass' => { 'label' => 'Package Class', + 'type' => 'select-pkg_class', + 'multiple' => 1, + }, + ); +} + +sub condition { + my( $self, $cust_pkg ) = @_; + + #XXX test + my $hashref = $self->option('pkgclass') || {}; + $hashref->{ $cust_pkg->part_pkg->classnum }; +} + +1; diff --git a/FS/FS/part_event/Condition/pkg_status.pm b/FS/FS/part_event/Condition/pkg_status.pm new file mode 100644 index 0000000..6c1c9cc --- /dev/null +++ b/FS/FS/part_event/Condition/pkg_status.pm @@ -0,0 +1,37 @@ +package FS::part_event::Condition::pkg_status; + +use strict; + +use base qw( FS::part_event::Condition ); +use FS::Record qw( qsearch ); + +sub description { + 'Package Status'; +} + +sub eventtable_hashref { + { 'cust_main' => 0, + 'cust_bill' => 0, + 'cust_pkg' => 1, + }; +} + +#something like this +sub option_fields { + ( + 'status' => { 'label' => 'Package Status', + 'type' => 'select-cust_pkg-status', + 'multiple' => 1, + }, + ); +} + +sub condition { + my( $self, $cust_pkg ) = @_; + + #XXX test + my $hashref = $self->option('status') || {}; + $hashref->{ $cust_pkg->status }; +} + +1; diff --git a/FS/FS/part_event_condition.pm b/FS/FS/part_event_condition.pm new file mode 100644 index 0000000..1efd0f8 --- /dev/null +++ b/FS/FS/part_event_condition.pm @@ -0,0 +1,343 @@ +package FS::part_event_condition; + +use strict; +use vars qw( @ISA $DEBUG ); +use FS::UID qw(dbh); +use FS::Record qw( qsearch qsearchs ); +use FS::option_Common; +use FS::part_event; #for order_conditions_sql... + +@ISA = qw( FS::option_Common ); # FS::Record ); +$DEBUG = 0; + +=head1 NAME + +FS::part_event_condition - Object methods for part_event_condition records + +=head1 SYNOPSIS + + use FS::part_event_condition; + + $record = new FS::part_event_condition \%hash; + $record = new FS::part_event_condition { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::part_event_condition object represents an event condition. +FS::part_event_condition inherits from FS::Record. The following fields are +currently supported: + +=over 4 + +=item eventconditionnum - primary key + +=item eventpart - Event definition (see L<FS::part_event>) + +=item conditionname - Condition name - defines which FS::part_event::Condition::I<conditionname> evaluates this condition + +=back + +=head1 METHODS + +=over 4 + +=item new HASHREF + +Creates a new event. To add the example to the database, see L<"insert">. + +Note that this stores the hash reference, not a distinct copy of the hash it +points to. You can ask the object for a copy with the I<hash> method. + +=cut + +# the new method can be inherited from FS::Record, if a table method is defined + +sub table { 'part_event_condition'; } + +=item insert [ HASHREF | OPTION => VALUE ... ] + +Adds this record to the database. If there is an error, returns the error, +otherwise returns false. + +If a list or hash reference of options is supplied, part_event_condition_option +records are created (see L<FS::part_event_condition_option>). + +=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 [ HASHREF | OPTION => VALUE ... ] + +Replaces the OLD_RECORD with this one in the database. If there is an error, +returns the error, otherwise returns false. + +If a list or hash reference of options is supplied, part_event_condition_option +records are created or modified (see L<FS::part_event_condition_option>). + +=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('eventconditionnum') + || $self->ut_foreign_key('eventpart', 'part_event', 'eventpart') + || $self->ut_alpha('conditionname') + ; + return $error if $error; + + #XXX check conditionname to make sure a module exists? + # well it'll die in _rebless... + + $self->SUPER::check; +} + + +=item _rebless + +Reblesses the object into the FS::part_event::Condition::CONDITIONNAME class, +where CONDITIONNAME is the object's I<conditionname> field. + +=cut + +sub _rebless { + my $self = shift; + my $conditionname = $self->conditionname; + #my $class = ref($self). "::$conditionname"; + my $class = "FS::part_event::Condition::$conditionname"; + eval "use $class"; + die $@ if $@; + bless($self, $class); #unless $@; + $self; +} + +=back + +=head1 CLASS METHODS + +=over 4 + +=item conditions [ EVENTTABLE ] + +Return information about the available conditions. If an eventtable is +specified, only return information about conditions available for that +eventtable. + +Information is returned as key-value pairs. Keys are condition names. Values +are hashrefs with the following keys: + +=over 4 + +=item description + +=item option_fields + +# =item default_weight + +# =item deprecated + +=back + +See L<FS::part_event::Condition> for more information. + +=cut + +#false laziness w/part_event.pm +#some false laziness w/part_export & part_pkg +my %conditions; +foreach my $INC ( @INC ) { + foreach my $file ( glob("$INC/FS/part_event/Condition/*.pm") ) { + warn "attempting to load Condition from $file\n" if $DEBUG; + $file =~ /\/(\w+)\.pm$/ or do { + warn "unrecognized file in $INC/FS/part_event/Condition/: $file\n"; + next; + }; + my $mod = $1; + my $fullmod = "FS::part_event::Condition::$mod"; + eval "use $fullmod;"; + if ( $@ ) { + die "error using $fullmod (skipping): $@\n" if $@; + #warn "error using $fullmod (skipping): $@\n" if $@; + #next; + } + #my $full_condition_sql = $fullmod. '::condition_sql'; + my $condition_sql_coderef = sub { $fullmod->condition_sql(@_) }; + my $order_sql_coderef = $fullmod->can('order_sql') + ? sub { $fullmod->order_sql(@_) } + : ''; + $conditions{$mod} = { + ( map { $_ => $fullmod->$_() } + qw( description eventtable_hashref + implicit_flag remove_warning + order_sql_weight + ) + # deprecated + #option_fields_hashref + ), + 'option_fields' => [ $fullmod->option_fields() ], + 'condition_sql' => $condition_sql_coderef, + 'order_sql' => $order_sql_coderef, + }; + } +} + +sub conditions { + my( $class, $eventtable ) = @_; + ( + map { $_ => $conditions{$_} } +# sort { $conditions{$a}->{'default_weight'}<=>$conditions{$b}->{'default_weight'} } +# sort by ? + $class->all_conditionnames( $eventtable ) + ); + +} + +=item all_conditionnames [ EVENTTABLE ] + +Returns a list of just the condition names + +=cut + +sub all_conditionnames { + my ( $class, $eventtable ) = @_; + + grep { !$eventtable || $conditions{$_}->{'eventtable_hashref'}{$eventtable} } + keys %conditions +} + +=item join_conditions_sql [ EVENTTABLE ] + +Returns an SQL fragment selecting joining all condition options for an event as +tables titled "cond_I<conditionname>". Typically used in conjunction with +B<where_conditions_sql>. + +=cut + +sub join_conditions_sql { + my ( $class, $eventtable ) = @_; + my %conditions = $class->conditions( $eventtable ); + + join(' ', + map { + "LEFT JOIN part_event_condition AS cond_$_". + " ON ( part_event.eventpart = cond_$_.eventpart". + " AND cond_$_.conditionname = ". dbh->quote($_). + " )"; + } + keys %conditions + ); + +} + +=item where_conditions_sql [ EVENTTABLE [ , OPTION => VALUE, ... ] ] + +Returns an SQL fragment to select events which have unsatisfied conditions. +Must be used in conjunction with B<join_conditions_sql>. + +The only current option is "time", the current time (or "pretend" current time +as passed to freeside-daily), as a UNIX timestamp. + +=cut + +sub where_conditions_sql { + my ( $class, $eventtable, %options ) = @_; + + my $time = $options{'time'}; + + my %conditions = $class->conditions( $eventtable ); + + my $where = join(' AND ', + map { + my $conditionname = $_; + my $coderef = $conditions{$conditionname}->{condition_sql}; + my $sql = &$coderef( $eventtable, 'time'=>$time ); + die "$coderef is not a CODEREF" unless ref($coderef) eq 'CODE'; + "( cond_$conditionname.conditionname IS NULL OR $sql )"; + } + keys %conditions + ); + + $where; +} + +=item order_conditions_sql [ EVENTTABLE ] + +Returns an SQL fragment to order selected events. Must be used in conjunction +with B<join_conditions_sql>. + +=cut + +sub order_conditions_sql { + my( $class, $eventtable ) = @_; + + my %conditions = $class->conditions( $eventtable ); + + my $eventtables = join(' ', FS::part_event->eventtables_runorder); + + my $order_by = join(', ', + "position( part_event.eventtable in ' $eventtables ')", + ( map { + my $conditionname = $_; + my $coderef = $conditions{$conditionname}->{order_sql}; + my $sql = &$coderef( $eventtable ); + "CASE WHEN cond_$conditionname.conditionname IS NULL + THEN -1 + ELSE $sql + END + "; + } + sort { $conditions{$a}->{order_sql_weight} + <=> $conditions{$b}->{order_sql_weight} + } + grep { $conditions{$_}->{order_sql} } + keys %conditions + ), + 'part_event.weight' + ); + + "ORDER BY $order_by"; + +} + +=back + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::part_event::Condition>, L<FS::part_event>, L<FS::Record>, schema.html from +the base documentation. + +=cut + +1; + diff --git a/FS/FS/part_event_condition_option.pm b/FS/FS/part_event_condition_option.pm new file mode 100644 index 0000000..3256dc0 --- /dev/null +++ b/FS/FS/part_event_condition_option.pm @@ -0,0 +1,151 @@ +package FS::part_event_condition_option; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); +use FS::option_Common; +use FS::part_event_condition; + +@ISA = qw( FS::option_Common ); # FS::Record); + +=head1 NAME + +FS::part_event_condition_option - Object methods for part_event_condition_option records + +=head1 SYNOPSIS + + use FS::part_event_condition_option; + + $record = new FS::part_event_condition_option \%hash; + $record = new FS::part_event_condition_option { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::part_event_condition_option object represents an event condition option. +FS::part_event_condition_option inherits from FS::Record. The following fields +are currently supported: + +=over 4 + +=item optionnum - primary key + +=item eventconditionnum - Event condition (see L<FS::part_event_condition>) + +=item optionname - Option name + +=item optionvalue - Option value + +=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 + +# the new method can be inherited from FS::Record, if a table method is defined + +sub table { 'part_event_condition_option'; } + +=item insert [ HASHREF | OPTION => VALUE ... ] + +Adds this record to the database. If there is an error, returns the error, +otherwise returns false. + +If a list or hash reference of options is supplied, +part_event_condition_option_option records are created (see +L<FS::part_event_condition_option_option>). + +=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 [ HASHREF | OPTION => VALUE ... ] + +Replaces the OLD_RECORD with this one in the database. If there is an error, +returns the error, otherwise returns false. + +If a list or hash reference of options is supplied, +part_event_condition_option_option records are created or modified (see +L<FS::part_event_condition_option_option>). + +=cut + +# the replace method can be inherited from FS::Record + +=item check + +Checks all fields to make sure this is a valid record. If there is +an error, returns the error, otherwise returns false. Called by the insert +and replace methods. + +=cut + +# the check method should currently be supplied - FS::Record contains some +# data checking routines + +sub check { + my $self = shift; + + my $error = + $self->ut_numbern('optionnum') + || $self->ut_foreign_key('eventconditionnum', + 'part_event_condition', 'eventconditionnum') + || $self->ut_text('optionname') + || $self->ut_textn('optionvalue') + ; + return $error if $error; + + $self->SUPER::check; +} + +#this makes the nested options magically show up as perl refs +#move it to a mixin class if we need nested options again +sub optionvalue { + my $self = shift; + if ( scalar(@_) ) { #setting, no magic (here, insert takes care of it) + $self->set('optionvalue', @_); + } else { #getting, magic + my $optionvalue = $self->get('optionvalue'); + if ( $optionvalue eq 'HASH' ) { + return { $self->options }; + } else { + $optionvalue; + } + } +} + +=back + +=head1 SEE ALSO + +L<FS::part_event_condition>, L<FS::part_event_condition_option_option>, +L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/part_event_condition_option_option.pm b/FS/FS/part_event_condition_option_option.pm new file mode 100644 index 0000000..7396c22 --- /dev/null +++ b/FS/FS/part_event_condition_option_option.pm @@ -0,0 +1,129 @@ +package FS::part_event_condition_option_option; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); +use FS::part_event_condition_option; + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::part_event_condition_option_option - Object methods for part_event_condition_option_option records + +=head1 SYNOPSIS + + use FS::part_event_condition_option_option; + + $record = new FS::part_event_condition_option_option \%hash; + $record = new FS::part_event_condition_option_option { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::part_event_condition_option_option object represents a nested event +condition option. FS::part_event_condition_option_option inherits from +FS::Record. The following fields are currently supported: + +=over 4 + +=item optionoptionnum - primary key + +=item optionnum - Parent option (see L<FS::part_event_option>) + +=item optionname - Option name + +=item optionvalue - Option value + + +=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 + +# the new method can be inherited from FS::Record, if a table method is defined + +sub table { 'part_event_condition_option_option'; } + +=item insert + +Adds this record to the database. If there is an error, returns the error, +otherwise returns false. + +=cut + +# the insert method can be inherited from FS::Record + +=item delete + +Delete this record from the database. + +=cut + +# the delete method can be inherited from FS::Record + +=item replace OLD_RECORD + +Replaces the OLD_RECORD with this one in the database. If there is an error, +returns the error, otherwise returns false. + +=cut + +# the replace method can be inherited from FS::Record + +=item check + +Checks all fields to make sure this is a valid 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; + + my $error = + $self->ut_numbern('optionoptionnum') + || $self->ut_foreign_key('optionnum', + 'part_event_condition_option', 'optionnum' ) + || $self->ut_text('optionname') + || $self->ut_textn('optionvalue') + ; + return $error if $error; + + $self->SUPER::check; +} + +=back + +=head1 BUGS + +=head1 SEE ALSO + +L<FS::part_event_condition_option>, L<FS::Record>, schema.html from the base +documentation. + +=cut + +1; + diff --git a/FS/FS/part_event_option.pm b/FS/FS/part_event_option.pm new file mode 100644 index 0000000..43e1da9 --- /dev/null +++ b/FS/FS/part_event_option.pm @@ -0,0 +1,213 @@ +package FS::part_event_option; + +use strict; +use vars qw( @ISA ); +use FS::UID qw( dbh ); +use FS::Record qw( qsearch qsearchs ); +use FS::part_event; +use FS::reason; + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::part_event_option - Object methods for part_event_option records + +=head1 SYNOPSIS + + use FS::part_event_option; + + $record = new FS::part_event_option \%hash; + $record = new FS::part_event_option { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::part_event_option object represents an event definition option (action +option). FS::part_event_option inherits from FS::Record. The following fields +are currently supported: + +=over 4 + +=item optionnum - primary key + +=item eventpart - Event definition (see L<FS::part_event>) + +=item optionname - Option name + +=item optionvalue - Option value + +=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 + +# the new method can be inherited from FS::Record, if a table method is defined + +sub table { 'part_event_option'; } + +=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; + + if ( $self->optionname eq 'reasonnum' && $self->optionvalue eq 'HASH' ) { + + my $error = $self->insert_reason(@_); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + } + + my $error = $self->SUPER::insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; + +} + +=item delete + +Delete this record from the database. + +=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 + +sub replace { + 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 $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') ) + ? shift + : $self->replace_old; + + if ( $self->optionname eq 'reasonnum' ) { + warn "reasonnum: ". $self->optionvalue; + } + if ( $self->optionname eq 'reasonnum' && $self->optionvalue eq 'HASH' ) { + + my $error = $self->insert_reason(@_); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + } + + my $error = $self->SUPER::replace($old); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + + ''; + +} + +=item check + +Checks all fields to make sure this is a valid record. If there is +an error, returns the error, otherwise returns false. Called by the insert +and replace methods. + +=cut + +# the check method should currently be supplied - FS::Record contains some +# data checking routines + +sub check { + my $self = shift; + + my $error = + $self->ut_numbern('optionnum') + || $self->ut_foreign_key('eventpart', 'part_event', 'eventpart' ) + || $self->ut_text('optionname') + || $self->ut_textn('optionvalue') + ; + return $error if $error; + + $self->SUPER::check; +} + +sub insert_reason { + my( $self, $reason ) = @_; + + my $reason_obj = new FS::reason({ + 'reason_type' => $reason->{'typenum'}, + 'reason' => $reason->{'reason'}, + }); + + $reason_obj->insert or $self->optionvalue( $reason_obj->reasonnum ) and ''; + +} + +=back + +=head1 SEE ALSO + +L<FS::part_event>, L<FS::Record>, schema.html from the base documentation. + +=cut + +1; + diff --git a/FS/FS/part_export/textradius.pm b/FS/FS/part_export/textradius.pm index 65936ea..3cd7039 100644 --- a/FS/FS/part_export/textradius.pm +++ b/FS/FS/part_export/textradius.pm @@ -30,7 +30,7 @@ operation</a>. END ); -$prefix = "/usr/local/etc/freeside/export."; +$prefix = "%%%FREESIDE_CONF%%%/export."; sub rebless { shift; } diff --git a/FS/FS/part_pkg/flat.pm b/FS/FS/part_pkg/flat.pm index 31658cd..6d1fbde 100644 --- a/FS/FS/part_pkg/flat.pm +++ b/FS/FS/part_pkg/flat.pm @@ -86,18 +86,24 @@ sub calc_setup { sub calc_recur { my($self, $cust_pkg) = @_; - $self->reset_usage($cust_pkg); $self->base_recur($cust_pkg); } sub base_recur { my($self, $cust_pkg) = @_; - $self->option('recur_fee'); + $self->option('recur_fee', 1) || 0; } sub calc_remain { - my ($self, $cust_pkg) = @_; - my $time = time; #should be able to pass this in for credit calculation + my ($self, $cust_pkg, %options) = @_; + + my $time; + if ($options{'time'}) { + $time = $options{'time'}; + } else { + $time = time; + } + my $next_bill = $cust_pkg->getfield('bill') || 0; my $last_bill = $cust_pkg->last_bill || 0; return 0 if ! $self->base_recur diff --git a/FS/FS/part_pkg/flat_delayed.pm b/FS/FS/part_pkg/flat_delayed.pm index caade40..8ac1682 100644 --- a/FS/FS/part_pkg/flat_delayed.pm +++ b/FS/FS/part_pkg/flat_delayed.pm @@ -48,4 +48,21 @@ sub calc_setup { $self->option('setup_fee'); } +sub calc_remain { + my ($self, $cust_pkg, %options) = @_; + my $next_bill = $cust_pkg->getfield('bill') || 0; + my $last_bill = $cust_pkg->last_bill || 0; + my $free_days = $self->option('free_days'); + + return 0 if $last_bill + (86400 * $free_days) == $next_bill + && $last_bill == $cust_pkg->setup; + + return 0 if ! $self->base_recur + || ! $self->option('unused_credit', 1) + || ! $last_bill + || ! $next_bill; + + return $self->SUPER::calc_remain($cust_pkg, %options); +} + 1; diff --git a/FS/FS/part_pkg/prorate.pm b/FS/FS/part_pkg/prorate.pm index 0c264e0..02ce6b9 100644 --- a/FS/FS/part_pkg/prorate.pm +++ b/FS/FS/part_pkg/prorate.pm @@ -21,7 +21,7 @@ use FS::part_pkg::flat; ' of service at cancellation', 'type' => 'checkbox', }, - 'cutoff_day' => { 'name' => 'billing day', + 'cutoff_day' => { 'name' => 'Billing_Day (1 - 28)', 'default' => 1, }, 'seconds' => { 'name' => 'Time limit for this package', diff --git a/FS/FS/part_pkg/prorate_delayed.pm b/FS/FS/part_pkg/prorate_delayed.pm new file mode 100644 index 0000000..ee66432 --- /dev/null +++ b/FS/FS/part_pkg/prorate_delayed.pm @@ -0,0 +1,61 @@ +package FS::part_pkg::prorate_delayed; + +use strict; +use vars qw(@ISA %info); +#use FS::Record qw(qsearch qsearchs); +use FS::part_pkg; + +@ISA = qw(FS::part_pkg::prorate); + +%info = ( + 'name' => 'Free (or setup fee) for X days, then prorate, then flat-rate ' . + '(1st of month billing)', + 'fields' => { + 'setup_fee' => { 'name' => 'Setup fee for this package', + 'default' => 0, + }, + 'free_days' => { 'name' => 'Initial free days', + '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' => [ 'free_days', 'setup_fee', 'recur_fee', '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, +); + +sub calc_setup { + my($self, $cust_pkg, $time ) = @_; + + my $d = $cust_pkg->bill || $time; + $d += 86400 * $self->option('free_days'); + $cust_pkg->bill($d); + + $self->option('setup_fee'); +} + +sub calc_remain { + my ($self, $cust_pkg, %options) = @_; + my $next_bill = $cust_pkg->getfield('bill') || 0; + my $last_bill = $cust_pkg->last_bill || 0; + my $free_days = $self->option('free_days'); + + return 0 if $last_bill + (86400 * $free_days) == $next_bill + && $last_bill == $cust_pkg->setup; + + return 0 if ! $self->base_recur + || ! $self->option('unused_credit', 1) + || ! $last_bill + || ! $next_bill; + + return $self->SUPER::calc_remain($cust_pkg, %options); +} + +1; diff --git a/FS/FS/part_pkg/subscription.pm b/FS/FS/part_pkg/subscription.pm index 0ed9782..00d15cd 100644 --- a/FS/FS/part_pkg/subscription.pm +++ b/FS/FS/part_pkg/subscription.pm @@ -89,8 +89,6 @@ sub calc_recur { $$sdate = timelocal(0,0,0,$cutoff_day,$mon,$year); - $self->reset_usage($cust_pkg); - $self->option('recur_fee'); } diff --git a/FS/FS/pay_batch.pm b/FS/FS/pay_batch.pm index 86ef7b0..8ae46ef 100644 --- a/FS/FS/pay_batch.pm +++ b/FS/FS/pay_batch.pm @@ -6,7 +6,6 @@ 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); @@ -454,6 +453,20 @@ sub import_results { $new_cust_pay_batch->status('Approved'); + } elsif ( &{$declined_condition}(\%hash) ) { + + $new_cust_pay_batch->status('Declined'); + + } + + 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"; + } + + if ( $new_cust_pay_batch->status =~ /Approved/i ) { + my $cust_pay = new FS::cust_pay ( { 'custnum' => $custnum, 'payby' => $payby, @@ -469,33 +482,38 @@ sub import_results { $cust_pay->cust_main->apply_payments; - } elsif ( &{$declined_condition}(\%hash) ) { + } elsif ( $new_cust_pay_batch->status =~ /Declined/i ) { - $new_cust_pay_batch->status('Declined'); + #false laziness w/cust_main::collect - foreach my $part_bill_event ( due_events ( $new_cust_pay_batch, - 'DCLN', - '', - '') ) { + my $due_cust_event = $new_cust_pay_batch->cust_main->due_cust_event( + #'check_freq' => '1d', #? + 'eventtable' => 'cust_pay_batch', + 'objects' => [ $new_cust_pay_batch ], + ); + unless( ref($due_cust_event) ) { + $dbh->rollback if $oldAutoCommit; + return $due_cust_event; + } - # don't run subsequent events if balance<=0 - last if $cust_pay_batch->cust_main->balance <= 0; + foreach my $cust_event ( @$due_cust_event ) { + + #XXX lock event + + #re-eval event conditions (a previous event could have changed things) + next unless $cust_event->test_conditions; - if (my $error = $part_bill_event->do_event($new_cust_pay_batch)) { + if ( my $error = $cust_event->do_event() ) { # gah, even with transactions. - $dbh->commit if $oldAutoCommit; #well. - return $error; + #$dbh->commit if $oldAutoCommit; #well. + $dbh->rollback if $oldAutoCommit; + 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"; - } } diff --git a/FS/FS/payby.pm b/FS/FS/payby.pm index 28afd03..6684c95 100644 --- a/FS/FS/payby.pm +++ b/FS/FS/payby.pm @@ -112,16 +112,6 @@ tie %hash, 'Tie::IxHash', 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 { diff --git a/FS/FS/pkg_referral.pm b/FS/FS/pkg_referral.pm new file mode 100644 index 0000000..333c2bf --- /dev/null +++ b/FS/FS/pkg_referral.pm @@ -0,0 +1,126 @@ +package FS::pkg_referral; + +use strict; +use vars qw( @ISA ); +use FS::Record qw( qsearch qsearchs ); + +@ISA = qw(FS::Record); + +=head1 NAME + +FS::pkg_referral - Object methods for pkg_referral records + +=head1 SYNOPSIS + + use FS::pkg_referral; + + $record = new FS::pkg_referral \%hash; + $record = new FS::pkg_referral { 'column' => 'value' }; + + $error = $record->insert; + + $error = $new_record->replace($old_record); + + $error = $record->delete; + + $error = $record->check; + +=head1 DESCRIPTION + +An FS::pkg_referral object represents the association of an advertising source +with a specific customer package (purchase). FS::pkg_referral inherits from +FS::Record. The following fields are currently supported: + +=over 4 + +=item pkgrefnum - primary key + +=item pkgnum - Customer package. See L<FS::cust_pkg> + +=item refnum - Advertising source. See L<FS::part_referral> + +=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 + +# the new method can be inherited from FS::Record, if a table method is defined + +sub table { 'pkg_referral'; } + +=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 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; + + my $error = + $self->ut_numbern('pkgrefnum') + || $self->ut_foreign_key('pkgnum', 'cust_pkg', 'pkgnum' ) + || $self->ut_foreign_key('refnum', 'part_referral', 'refnum' ) + ; + return $error if $error; + + $self->SUPER::check; +} + +=back + +=head1 BUGS + +Multiple pkg_referral records for a single package (configured off by default) +still seems weird. + +=head1 SEE ALSO + +L<FS::part_referral>, L<FS::cust_pkg>, 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 fd3a46a..787acee 100644 --- a/FS/FS/svc_Common.pm +++ b/FS/FS/svc_Common.pm @@ -187,6 +187,9 @@ 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)). +If I<export_args> is set to an array reference, the referenced list will be +passed to export commands. + =cut sub insert { @@ -279,8 +282,10 @@ sub insert { warn "[$me] insert: \$FS::queue::jobnums is $FS::queue::jobnums\n" if $DEBUG; + my $export_args = $options{'export_args'} || []; + foreach my $part_export ( $self->cust_svc->part_svc->part_export ) { - my $error = $part_export->export_insert($self); + my $error = $part_export->export_insert($self, @$export_args); if ( $error ) { $dbh->rollback if $oldAutoCommit; return "exporting to ". $part_export->exporttype. @@ -314,7 +319,7 @@ sub insert { ''; } -=item delete +=item delete [ , OPTION => VALUE ... ] Deletes this account from the database. If there is an error, returns the error, otherwise returns false. @@ -325,7 +330,8 @@ The corresponding FS::cust_svc record will be deleted as well. sub delete { my $self = shift; - my $error; + my %options = @_; + my $export_args = $options{'export_args'} || []; local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; @@ -338,10 +344,10 @@ sub delete { local $FS::UID::AutoCommit = 0; my $dbh = dbh; - $error = $self->SUPER::delete - || $self->export('delete') - || $self->return_inventory - || $self->cust_svc->delete + my $error = $self->SUPER::delete + || $self->export('delete', @$export_args) + || $self->return_inventory + || $self->cust_svc->delete ; if ( $error ) { $dbh->rollback if $oldAutoCommit; @@ -362,6 +368,7 @@ otherwise returns false. sub replace { my ($new, $old) = (shift, shift); + my %options = @_; local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; @@ -392,6 +399,8 @@ sub replace { #new-style exports! unless ( $noexport_hack ) { + my $export_args = $options{'export_args'} || []; + #not quite false laziness, but same pattern as FS::svc_acct::replace and #FS::part_export::sqlradius::_export_replace. List::Compare or something #would be useful but too much of a pain in the ass to deploy @@ -407,7 +416,7 @@ sub replace { foreach my $delete_part_export ( grep { ! $new_exportnum{$_->exportnum} } @old_part_export ) { - my $error = $delete_part_export->export_delete($old); + my $error = $delete_part_export->export_delete($old, @$export_args); if ( $error ) { $dbh->rollback if $oldAutoCommit; return "error deleting, export to ". $delete_part_export->exporttype. @@ -418,7 +427,8 @@ sub replace { foreach my $replace_part_export ( grep { $old_exportnum{$_->exportnum} } @new_part_export ) { - my $error = $replace_part_export->export_replace($new,$old); + my $error = + $replace_part_export->export_replace( $new, $old, @$export_args); if ( $error ) { $dbh->rollback if $oldAutoCommit; return "error exporting to ". $replace_part_export->exporttype. @@ -429,7 +439,7 @@ sub replace { foreach my $insert_part_export ( grep { ! $old_exportnum{$_->exportnum} } @new_part_export ) { - my $error = $insert_part_export->export_insert($new); + my $error = $insert_part_export->export_insert($new, @$export_args ); if ( $error ) { $dbh->rollback if $oldAutoCommit; return "error inserting export to ". $insert_part_export->exporttype. @@ -443,7 +453,6 @@ sub replace { ''; } - =item setfixed Sets any fixed fields for this service (see L<FS::part_svc>). If there is an @@ -681,7 +690,9 @@ Runs export_suspend callbacks. sub suspend { my $self = shift; - $self->export('suspend'); + my %options = @_; + my $export_args = $options{'export_args'} || []; + $self->export('suspend', @$export_args); } =item unsuspend @@ -692,7 +703,9 @@ Runs export_unsuspend callbacks. sub unsuspend { my $self = shift; - $self->export('unsuspend'); + my %options = @_; + my $export_args = $options{'export_args'} || []; + $self->export('unsuspend', @$export_args); } =item export HOOK [ EXPORT_ARGS ] diff --git a/FS/FS/svc_acct.pm b/FS/FS/svc_acct.pm index 2e5da78..fc950fa 100644 --- a/FS/FS/svc_acct.pm +++ b/FS/FS/svc_acct.pm @@ -779,7 +779,7 @@ sub replace { } } - $error = $new->SUPER::replace($old); + $error = $new->SUPER::replace($old, @_); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error if $error; @@ -845,7 +845,7 @@ Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>). sub suspend { my $self = shift; return "can't suspend system account" if $self->_check_system; - $self->SUPER::suspend; + $self->SUPER::suspend(@_); } =item unsuspend @@ -867,7 +867,7 @@ sub unsuspend { return $error if $error; } - $self->SUPER::unsuspend; + $self->SUPER::unsuspend(@_); } =item cancel @@ -898,7 +898,7 @@ sub cancel { } } - $self->SUPER::cancel; + $self->SUPER::cancel(@_); } diff --git a/FS/FS/svc_domain.pm b/FS/FS/svc_domain.pm index 5291271..803ebef 100644 --- a/FS/FS/svc_domain.pm +++ b/FS/FS/svc_domain.pm @@ -271,7 +271,7 @@ sub delete { } } - my $error = $self->SUPER::delete; + my $error = $self->SUPER::delete(@_); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; @@ -298,7 +298,7 @@ sub replace { # Better to do it here than to force the caller to remember that svc_domain is weird. $new->setfield(action => 'M'); - my $error = $new->SUPER::replace($old); + my $error = $new->SUPER::replace($old, @_); return $error if $error; } diff --git a/FS/FS/svc_forward.pm b/FS/FS/svc_forward.pm index 91e251f..3250f8a 100644 --- a/FS/FS/svc_forward.pm +++ b/FS/FS/svc_forward.pm @@ -195,7 +195,7 @@ sub delete { local $FS::UID::Autocommit = 0; my $dbh = dbh; - my $error = $self->SUPER::delete; + my $error = $self->SUPER::delete(@_); if ( $error ) { $dbh->rollback if $oldAutoCommit; return $error; @@ -235,7 +235,7 @@ sub replace { local $FS::UID::AutoCommit = 0; my $dbh = dbh; - my $error = $new->SUPER::replace($old); + my $error = $new->SUPER::replace($old, @_); if ($error) { $dbh->rollback if $oldAutoCommit; return $error; diff --git a/FS/FS/svc_www.pm b/FS/FS/svc_www.pm index 49c5ea9..53225bb 100644 --- a/FS/FS/svc_www.pm +++ b/FS/FS/svc_www.pm @@ -176,7 +176,7 @@ sub delete { my $self = shift; my $error; - $error = $self->SUPER::delete; + $error = $self->SUPER::delete(@_); return $error if $error; ''; @@ -193,7 +193,7 @@ sub replace { my ( $new, $old ) = ( shift, shift ); my $error; - $error = $new->SUPER::replace($old); + $error = $new->SUPER::replace($old, @_); return $error if $error; ''; diff --git a/FS/MANIFEST b/FS/MANIFEST index 6a4c1ce..c30cd15 100644 --- a/FS/MANIFEST +++ b/FS/MANIFEST @@ -2,7 +2,6 @@ Changes MANIFEST MANIFEST.SKIP Makefile.PL -README bin/freeside-addoutsource bin/freeside-addoutsourceuser bin/freeside-addgroup @@ -371,6 +370,20 @@ FS/reason.pm t/reason.t FS/reason_type.pm t/reason_type.t +FS/pkg_referral.pm +t/pkg_referral.t +FS/part_event_option.pm +t/part_event_option.t +FS/part_event_condition.pm +t/part_event_condition.t +FS/part_event_condition_option.pm +t/part_event_condition_option.t +FS/part_event.pm +t/part_event.t +FS/cust_event.pm +t/cust_event.t +FS/part_event_condition_option_option.pm +t/part_event_condition_option_option.t FS/cust_pkg_option.pm t/cust_pkg_option.t FS/conf.pm diff --git a/FS/README b/FS/README deleted file mode 100644 index d4c35ac..0000000 --- a/FS/README +++ /dev/null @@ -1,6 +0,0 @@ -This is the Perl module section of Freeside. - -perl Makefile.PL -make -make test -make install diff --git a/FS/bin/freeside-daily b/FS/bin/freeside-daily index d5748d6..f0ec9f0 100755 --- a/FS/bin/freeside-daily +++ b/FS/bin/freeside-daily @@ -6,7 +6,7 @@ use FS::UID qw(adminsuidsetup); &untaint_argv; #what it sounds like (eww) use vars qw(%opt); -getopts("p:a:d:vsy:n", \%opt); +getopts("p:a:d:vl:sy:n", \%opt); my $user = shift or die &usage; adminsuidsetup $user; @@ -14,9 +14,14 @@ adminsuidsetup $user; use FS::Cron::bill qw(bill); bill(%opt); +#what to do about the below when using -m? that is the question. + use FS::Cron::notify qw(notify_flat_delay); notify_flat_delay(%opt); +use FS::Cron::expire_user_pref qw(expire_user_pref); +expire_user_pref(); + use FS::Cron::vacuum qw(vacuum); vacuum(); @@ -50,7 +55,7 @@ freeside-daily - Run daily billing and invoice collection events. =head1 SYNOPSIS - freeside-daily [ -d 'date' ] [ -y days ] [ -p 'payby' ] [ -a agentnum ] [ -s ] [ -v ] user [ custnum custnum ... ] + freeside-daily [ -d 'date' ] [ -y days ] [ -p 'payby' ] [ -a agentnum ] [ -s ] [ -v ] [ -l level ] user [ custnum custnum ... ] =head1 DESCRIPTION @@ -80,6 +85,10 @@ the bill and collect methods of a cust_main object. See L<FS::cust_main>. -v: enable debugging + -l: debugging level + + -m: Experimental multi-process mode uses the job queue for multi-process and/or multi-machine billing. + user: From the mapsecrets file - see config.html from the base documentation custnum: if one or more customer numbers are specified, only bills those diff --git a/FS/bin/freeside-monthly b/FS/bin/freeside-monthly index a6c75e7..1e41b78 100755 --- a/FS/bin/freeside-monthly +++ b/FS/bin/freeside-monthly @@ -13,7 +13,7 @@ my $user = shift or die &usage; adminsuidsetup $user; use FS::Cron::bill qw(bill); -bill(%opt, 'freq'=>'1m' ); +bill(%opt, 'check_freq'=>'1m' ); ### # subroutines diff --git a/FS/t/cust_event.t b/FS/t/cust_event.t new file mode 100644 index 0000000..7812c5b --- /dev/null +++ b/FS/t/cust_event.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::cust_event; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/part_event-Action.t b/FS/t/part_event-Action.t new file mode 100644 index 0000000..a665277 --- /dev/null +++ b/FS/t/part_event-Action.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::part_event::Action; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/part_event-Condition.t b/FS/t/part_event-Condition.t new file mode 100644 index 0000000..c44a438 --- /dev/null +++ b/FS/t/part_event-Condition.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::part_event::Condition; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/part_event.t b/FS/t/part_event.t new file mode 100644 index 0000000..027b20c --- /dev/null +++ b/FS/t/part_event.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::part_event; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/part_event_condition.t b/FS/t/part_event_condition.t new file mode 100644 index 0000000..fa5a05c --- /dev/null +++ b/FS/t/part_event_condition.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::part_event_condition; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/part_event_condition_option.t b/FS/t/part_event_condition_option.t new file mode 100644 index 0000000..492fc82 --- /dev/null +++ b/FS/t/part_event_condition_option.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::part_event_condition_option; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/part_event_condition_option_option.t b/FS/t/part_event_condition_option_option.t new file mode 100644 index 0000000..f714011 --- /dev/null +++ b/FS/t/part_event_condition_option_option.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::part_event_condition_option_option; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/part_event_option.t b/FS/t/part_event_option.t new file mode 100644 index 0000000..546a78f --- /dev/null +++ b/FS/t/part_event_option.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::part_event_option; +$loaded=1; +print "ok 1\n"; diff --git a/FS/t/pkg_referral.t b/FS/t/pkg_referral.t new file mode 100644 index 0000000..ff047ba --- /dev/null +++ b/FS/t/pkg_referral.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::pkg_referral; +$loaded=1; +print "ok 1\n"; |