4 use vars qw(@ISA $disable_agentcheck $DEBUG);
5 use List::Util qw(max);
7 use FS::UID qw( getotaker dbh );
8 use FS::Misc qw( send_email );
9 use FS::Record qw( qsearch qsearchs );
11 use FS::cust_main_Mixin;
17 use FS::cust_bill_pkg;
22 use FS::cust_pkg_reason;
25 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
27 # because they load configuration by setting FS::UID::callback (see TODO)
33 # for sending cancel emails in sub cancel
36 @ISA = qw( FS::m2m_Common FS::cust_main_Mixin FS::option_Common FS::Record );
40 $disable_agentcheck = 0;
44 my ( $hashref, $cache ) = @_;
45 #if ( $hashref->{'pkgpart'} ) {
46 if ( $hashref->{'pkg'} ) {
47 # #@{ $self->{'_pkgnum'} } = ();
48 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
49 # $self->{'_pkgpart'} = $subcache;
50 # #push @{ $self->{'_pkgnum'} },
51 # FS::part_pkg->new_or_cached($hashref, $subcache);
52 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
54 if ( exists $hashref->{'svcnum'} ) {
55 #@{ $self->{'_pkgnum'} } = ();
56 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
57 $self->{'_svcnum'} = $subcache;
58 #push @{ $self->{'_pkgnum'} },
59 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
65 FS::cust_pkg - Object methods for cust_pkg objects
71 $record = new FS::cust_pkg \%hash;
72 $record = new FS::cust_pkg { 'column' => 'value' };
74 $error = $record->insert;
76 $error = $new_record->replace($old_record);
78 $error = $record->delete;
80 $error = $record->check;
82 $error = $record->cancel;
84 $error = $record->suspend;
86 $error = $record->unsuspend;
88 $part_pkg = $record->part_pkg;
90 @labels = $record->labels;
92 $seconds = $record->seconds_since($timestamp);
94 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
95 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
99 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
100 inherits from FS::Record. The following fields are currently supported:
104 =item pkgnum - primary key (assigned automatically for new billing items)
106 =item custnum - Customer (see L<FS::cust_main>)
108 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
112 =item bill - date (next bill date)
114 =item last_bill - last bill date
124 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
126 =item manual_flag - If this field is set to 1, disables the automatic
127 unsuspension of this package when using the B<unsuspendauto> config file.
131 Note: setup, bill, adjourn, susp, expire and cancel are specified as UNIX timestamps;
132 see L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for
133 conversion functions.
141 Create a new billing item. To add the item to the database, see L<"insert">.
145 sub table { 'cust_pkg'; }
146 sub cust_linked { $_[0]->cust_main_custnum; }
147 sub cust_unlinked_msg {
149 "WARNING: can't find cust_main.custnum ". $self->custnum.
150 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
153 =item insert [ OPTION => VALUE ... ]
155 Adds this billing item to the database ("Orders" the item). If there is an
156 error, returns the error, otherwise returns false.
158 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
159 will be used to look up the package definition and agent restrictions will be
162 If the additional field I<refnum> is defined, an FS::pkg_referral record will
163 be created and inserted. Multiple FS::pkg_referral records can be created by
164 setting I<refnum> to an array reference of refnums or a hash reference with
165 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
166 record will be created corresponding to cust_main.refnum.
168 The following options are available: I<change>
170 I<change>, if set true, supresses any referral credit to a referring customer.
175 my( $self, %options ) = @_;
177 local $SIG{HUP} = 'IGNORE';
178 local $SIG{INT} = 'IGNORE';
179 local $SIG{QUIT} = 'IGNORE';
180 local $SIG{TERM} = 'IGNORE';
181 local $SIG{TSTP} = 'IGNORE';
182 local $SIG{PIPE} = 'IGNORE';
184 my $oldAutoCommit = $FS::UID::AutoCommit;
185 local $FS::UID::AutoCommit = 0;
188 my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
190 $dbh->rollback if $oldAutoCommit;
194 $self->refnum($self->cust_main->refnum) unless $self->refnum;
195 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
196 $self->process_m2m( 'link_table' => 'pkg_referral',
197 'target_table' => 'part_referral',
198 'params' => $self->refnum,
201 #if ( $self->reg_code ) {
202 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
203 # $error = $reg_code->delete;
205 # $dbh->rollback if $oldAutoCommit;
210 my $conf = new FS::Conf;
211 my $cust_main = $self->cust_main;
212 my $part_pkg = $self->part_pkg;
213 if ( $conf->exists('referral_credit')
214 && $cust_main->referral_custnum
215 && ! $options{'change'}
216 && $part_pkg->freq !~ /^0\D?$/
219 my $referring_cust_main = $cust_main->referring_cust_main;
220 if ( $referring_cust_main->status ne 'cancelled' ) {
222 if ( $part_pkg->freq !~ /^\d+$/ ) {
223 warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum.
224 ' for package '. $self->pkgnum.
225 ' ( customer '. $self->custnum. ')'.
226 ' - One-time referral credits not (yet) available for '.
227 ' packages with '. $part_pkg->freq_pretty. ' frequency';
230 my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
232 $referring_cust_main->
234 'Referral credit for '.$cust_main->name,
235 'reason_type' => $conf->config('referral_credit_type')
238 $dbh->rollback if $oldAutoCommit;
239 return "Error crediting customer ". $cust_main->referral_custnum.
240 " for referral: $error";
248 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
249 my $queue = new FS::queue {
250 'job' => 'FS::cust_main::queueable_print',
252 $error = $queue->insert(
253 'custnum' => $self->custnum,
254 'template' => 'welcome_letter',
258 warn "can't send welcome letter: $error";
263 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
270 This method now works but you probably shouldn't use it.
272 You don't want to delete billing items, because there would then be no record
273 the customer ever purchased the item. Instead, see the cancel method.
278 # return "Can't delete cust_pkg records!";
281 =item replace OLD_RECORD
283 Replaces the OLD_RECORD with this one in the database. If there is an error,
284 returns the error, otherwise returns false.
286 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
288 Changing pkgpart may have disasterous effects. See the order subroutine.
290 setup and bill are normally updated by calling the bill method of a customer
291 object (see L<FS::cust_main>).
293 suspend is normally updated by the suspend and unsuspend methods.
295 cancel is normally updated by the cancel method (and also the order subroutine
303 my( $new, $old, %options ) = @_;
305 # We absolutely have to have an old vs. new record to make this work.
306 if (!defined($old)) {
307 $old = qsearchs( 'cust_pkg', { 'pkgnum' => $new->pkgnum } );
309 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
310 return "Can't change otaker!" if $old->otaker ne $new->otaker;
313 #return "Can't change setup once it exists!"
314 # if $old->getfield('setup') &&
315 # $old->getfield('setup') != $new->getfield('setup');
317 #some logic for bill, susp, cancel?
319 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
321 local $SIG{HUP} = 'IGNORE';
322 local $SIG{INT} = 'IGNORE';
323 local $SIG{QUIT} = 'IGNORE';
324 local $SIG{TERM} = 'IGNORE';
325 local $SIG{TSTP} = 'IGNORE';
326 local $SIG{PIPE} = 'IGNORE';
328 my $oldAutoCommit = $FS::UID::AutoCommit;
329 local $FS::UID::AutoCommit = 0;
332 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
333 if ($options{'reason'} && $new->$method && $old->$method ne $new->$method) {
334 my $error = $new->insert_reason( 'reason' => $options{'reason'},
335 'date' => $new->$method,
338 dbh->rollback if $oldAutoCommit;
339 return "Error inserting cust_pkg_reason: $error";
344 #save off and freeze RADIUS attributes for any associated svc_acct records
346 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
348 #also check for specific exports?
349 # to avoid spurious modify export events
350 @svc_acct = map { $_->svc_x }
351 grep { $_->part_svc->svcdb eq 'svc_acct' }
354 $_->snapshot foreach @svc_acct;
358 my $error = $new->SUPER::replace($old,
359 $options{options} ? ${options{options}} : ()
362 $dbh->rollback if $oldAutoCommit;
366 #for prepaid packages,
367 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
368 foreach my $old_svc_acct ( @svc_acct ) {
369 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
370 my $s_error = $new_svc_acct->replace($old_svc_acct);
372 $dbh->rollback if $oldAutoCommit;
377 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
384 Checks all fields to make sure this is a valid billing item. If there is an
385 error, returns the error, otherwise returns false. Called by the insert and
394 $self->ut_numbern('pkgnum')
395 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
396 || $self->ut_numbern('pkgpart')
397 || $self->ut_numbern('setup')
398 || $self->ut_numbern('bill')
399 || $self->ut_numbern('susp')
400 || $self->ut_numbern('cancel')
401 || $self->ut_numbern('adjourn')
402 || $self->ut_numbern('expire')
404 return $error if $error;
406 if ( $self->reg_code ) {
408 unless ( grep { $self->pkgpart == $_->pkgpart }
409 map { $_->reg_code_pkg }
410 qsearchs( 'reg_code', { 'code' => $self->reg_code,
411 'agentnum' => $self->cust_main->agentnum })
413 return "Unknown registration code";
416 } elsif ( $self->promo_code ) {
419 qsearchs('part_pkg', {
420 'pkgpart' => $self->pkgpart,
421 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
423 return 'Unknown promotional code' unless $promo_part_pkg;
427 unless ( $disable_agentcheck ) {
429 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
430 my $pkgpart_href = $agent->pkgpart_hashref;
431 return "agent ". $agent->agentnum.
432 " can't purchase pkgpart ". $self->pkgpart
433 unless $pkgpart_href->{ $self->pkgpart };
436 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
437 return $error if $error;
441 $self->otaker(getotaker) unless $self->otaker;
442 $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker";
445 if ( $self->dbdef_table->column('manual_flag') ) {
446 $self->manual_flag('') if $self->manual_flag eq ' ';
447 $self->manual_flag =~ /^([01]?)$/
448 or return "Illegal manual_flag ". $self->manual_flag;
449 $self->manual_flag($1);
455 =item cancel [ OPTION => VALUE ... ]
457 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
458 in this package, then cancels the package itself (sets the cancel field to
461 Available options are:
465 =item quiet - can be set true to supress email cancellation notices.
467 =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.
469 =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.
473 If there is an error, returns the error, otherwise returns false.
478 my( $self, %options ) = @_;
480 warn "cust_pkg::cancel called with options".
481 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
484 local $SIG{HUP} = 'IGNORE';
485 local $SIG{INT} = 'IGNORE';
486 local $SIG{QUIT} = 'IGNORE';
487 local $SIG{TERM} = 'IGNORE';
488 local $SIG{TSTP} = 'IGNORE';
489 local $SIG{PIPE} = 'IGNORE';
491 my $oldAutoCommit = $FS::UID::AutoCommit;
492 local $FS::UID::AutoCommit = 0;
495 my $cancel_time = $options{'time'} || time;
499 if ( $options{'reason'} ) {
500 $error = $self->insert_reason( 'reason' => $options{'reason'} );
502 dbh->rollback if $oldAutoCommit;
503 return "Error inserting cust_pkg_reason: $error";
508 foreach my $cust_svc (
511 sort { $a->[1] <=> $b->[1] }
512 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
513 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
516 my $error = $cust_svc->cancel;
519 $dbh->rollback if $oldAutoCommit;
520 return "Error cancelling cust_svc: $error";
524 unless ( $self->getfield('cancel') ) {
525 # Add a credit for remaining service
526 my $remaining_value = $self->calc_remain(time=>$cancel_time);
527 if ( $remaining_value > 0 && !$options{'no_credit'} ) {
528 my $conf = new FS::Conf;
529 my $error = $self->cust_main->credit(
531 'Credit for unused time on '. $self->part_pkg->pkg,
532 'reason_type' => $conf->config('cancel_credit_type'),
535 $dbh->rollback if $oldAutoCommit;
536 return "Error crediting customer \$$remaining_value for unused time on".
537 $self->part_pkg->pkg. ": $error";
540 my %hash = $self->hash;
541 $hash{'cancel'} = $cancel_time;
542 my $new = new FS::cust_pkg ( \%hash );
543 $error = $new->replace( $self, options => { $self->options } );
545 $dbh->rollback if $oldAutoCommit;
550 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
552 my $conf = new FS::Conf;
553 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
554 if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
555 my $conf = new FS::Conf;
556 my $error = send_email(
557 'from' => $conf->config('invoice_from'),
558 'to' => \@invoicing_list,
559 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
560 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
562 #should this do something on errors?
569 =item cancel_if_expired [ NOW_TIMESTAMP ]
571 Cancels this package if its expire date has been reached.
575 sub cancel_if_expired {
577 my $time = shift || time;
578 return '' unless $self->expire && $self->expire <= $time;
579 my $error = $self->cancel;
581 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
582 $self->custnum. ": $error";
587 =item suspend [ OPTION => VALUE ... ]
589 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
590 package, then suspends the package itself (sets the susp field to now).
592 Available options are:
596 =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.
600 If there is an error, returns the error, otherwise returns false.
605 my( $self, %options ) = @_;
607 local $SIG{HUP} = 'IGNORE';
608 local $SIG{INT} = 'IGNORE';
609 local $SIG{QUIT} = 'IGNORE';
610 local $SIG{TERM} = 'IGNORE';
611 local $SIG{TSTP} = 'IGNORE';
612 local $SIG{PIPE} = 'IGNORE';
614 my $oldAutoCommit = $FS::UID::AutoCommit;
615 local $FS::UID::AutoCommit = 0;
620 if ( $options{'reason'} ) {
621 $error = $self->insert_reason( 'reason' => $options{'reason'} );
623 dbh->rollback if $oldAutoCommit;
624 return "Error inserting cust_pkg_reason: $error";
628 foreach my $cust_svc (
629 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
631 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
633 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
634 $dbh->rollback if $oldAutoCommit;
635 return "Illegal svcdb value in part_svc!";
638 require "FS/$svcdb.pm";
640 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
642 $error = $svc->suspend;
644 $dbh->rollback if $oldAutoCommit;
651 unless ( $self->getfield('susp') ) {
652 my %hash = $self->hash;
653 $hash{'susp'} = time;
654 my $new = new FS::cust_pkg ( \%hash );
655 $error = $new->replace( $self, options => { $self->options } );
657 $dbh->rollback if $oldAutoCommit;
662 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
667 =item unsuspend [ OPTION => VALUE ... ]
669 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
670 package, then unsuspends the package itself (clears the susp field and the
671 adjourn field if it is in the past).
673 Available options are: I<adjust_next_bill>.
675 I<adjust_next_bill> can be set true to adjust the next bill date forward by
676 the amount of time the account was inactive. This was set true by default
677 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
678 explicitly requested. Price plans for which this makes sense (anniversary-date
679 based than prorate or subscription) could have an option to enable this
682 If there is an error, returns the error, otherwise returns false.
687 my( $self, %opt ) = @_;
690 local $SIG{HUP} = 'IGNORE';
691 local $SIG{INT} = 'IGNORE';
692 local $SIG{QUIT} = 'IGNORE';
693 local $SIG{TERM} = 'IGNORE';
694 local $SIG{TSTP} = 'IGNORE';
695 local $SIG{PIPE} = 'IGNORE';
697 my $oldAutoCommit = $FS::UID::AutoCommit;
698 local $FS::UID::AutoCommit = 0;
701 foreach my $cust_svc (
702 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
704 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
706 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
707 $dbh->rollback if $oldAutoCommit;
708 return "Illegal svcdb value in part_svc!";
711 require "FS/$svcdb.pm";
713 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
715 $error = $svc->unsuspend;
717 $dbh->rollback if $oldAutoCommit;
724 unless ( ! $self->getfield('susp') ) {
725 my %hash = $self->hash;
726 my $inactive = time - $hash{'susp'};
728 my $conf = new FS::Conf;
730 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
731 if ( $opt{'adjust_next_bill'}
732 || $conf->config('unsuspend-always_adjust_next_bill_date') )
733 && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
736 $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
737 my $new = new FS::cust_pkg ( \%hash );
738 $error = $new->replace( $self, options => { $self->options } );
740 $dbh->rollback if $oldAutoCommit;
745 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
752 Returns the last bill date, or if there is no last bill date, the setup date.
753 Useful for billing metered services.
759 if ( $self->dbdef_table->column('last_bill') ) {
760 return $self->setfield('last_bill', $_[0]) if @_;
761 return $self->getfield('last_bill') if $self->getfield('last_bill');
763 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
764 'edate' => $self->bill, } );
765 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
770 Returns the most recent FS::reason associated with the package.
776 my $cust_pkg_reason = qsearchs( {
777 'table' => 'cust_pkg_reason',
778 'hashref' => { 'pkgnum' => $self->pkgnum, },
779 'extra_sql'=> 'ORDER BY date DESC LIMIT 1',
781 qsearchs ( 'reason', { 'reasonnum' => $cust_pkg_reason->reasonnum } )
787 Returns the definition for this billing item, as an FS::part_pkg object (see
794 #exists( $self->{'_pkgpart'} )
796 ? $self->{'_pkgpart'}
797 : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
802 Returns the cancelled package this package was changed from, if any.
808 return '' unless $self->change_pkgnum;
809 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
814 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
821 $self->part_pkg->calc_setup($self, @_);
826 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
833 $self->part_pkg->calc_recur($self, @_);
838 Calls the I<calc_remain> of the FS::part_pkg object associated with this
845 $self->part_pkg->calc_remain($self, @_);
850 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
857 $self->part_pkg->calc_cancel($self, @_);
862 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
868 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
873 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
877 #false laziness w/cust_bill.pm
881 'table' => 'cust_event',
882 'addl_from' => 'JOIN part_event USING ( eventpart )',
883 'hashref' => { 'tablenum' => $self->pkgnum },
884 'extra_sql' => " AND eventtable = 'cust_pkg' ",
890 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
894 #false laziness w/cust_bill.pm
898 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
899 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
900 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
901 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
902 $sth->fetchrow_arrayref->[0];
905 =item cust_svc [ SVCPART ]
907 Returns the services for this package, as FS::cust_svc objects (see
908 L<FS::cust_svc>). If a svcpart is specified, return only the matching
917 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
918 'svcpart' => shift, } );
921 #if ( $self->{'_svcnum'} ) {
922 # values %{ $self->{'_svcnum'}->cache };
924 $self->_sort_cust_svc(
925 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
931 =item overlimit [ SVCPART ]
933 Returns the services for this package which have exceeded their
934 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
935 is specified, return only the matching services.
941 grep { $_->overlimit } $self->cust_svc;
944 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
946 Returns historical services for this package created before END TIMESTAMP and
947 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
948 (see L<FS::h_cust_svc>).
955 $self->_sort_cust_svc(
956 [ qsearch( 'h_cust_svc',
957 { 'pkgnum' => $self->pkgnum, },
958 FS::h_cust_svc->sql_h_search(@_),
965 my( $self, $arrayref ) = @_;
968 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
970 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
971 'svcpart' => $_->svcpart } );
973 $pkg_svc ? $pkg_svc->primary_svc : '',
974 $pkg_svc ? $pkg_svc->quantity : 0,
981 =item num_cust_svc [ SVCPART ]
983 Returns the number of provisioned services for this package. If a svcpart is
984 specified, counts only the matching services.
990 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
991 $sql .= ' AND svcpart = ?' if @_;
992 my $sth = dbh->prepare($sql) or die dbh->errstr;
993 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
994 $sth->fetchrow_arrayref->[0];
997 =item available_part_svc
999 Returns a list of FS::part_svc objects representing services included in this
1000 package but not yet provisioned. Each FS::part_svc object also has an extra
1001 field, I<num_avail>, which specifies the number of available services.
1005 sub available_part_svc {
1007 grep { $_->num_avail > 0 }
1009 my $part_svc = $_->part_svc;
1010 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1011 $_->quantity - $self->num_cust_svc($_->svcpart);
1014 $self->part_pkg->pkg_svc;
1019 Returns a list of FS::part_svc objects representing provisioned and available
1020 services included in this package. Each FS::part_svc object also has the
1021 following extra fields:
1025 =item num_cust_svc (count)
1027 =item num_avail (quantity - count)
1029 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1032 label -> ($cust_svc->label)[1]
1041 #XXX some sort of sort order besides numeric by svcpart...
1042 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1044 my $part_svc = $pkg_svc->part_svc;
1045 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1046 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1047 $part_svc->{'Hash'}{'num_avail'} =
1048 max( 0, $pkg_svc->quantity - $num_cust_svc );
1049 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1051 } $self->part_pkg->pkg_svc;
1054 push @part_svc, map {
1056 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1057 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1058 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
1059 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1061 } $self->extra_part_svc;
1067 =item extra_part_svc
1069 Returns a list of FS::part_svc objects corresponding to services in this
1070 package which are still provisioned but not (any longer) available in the
1075 sub extra_part_svc {
1078 my $pkgnum = $self->pkgnum;
1079 my $pkgpart = $self->pkgpart;
1082 'table' => 'part_svc',
1084 'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1085 WHERE pkg_svc.svcpart = part_svc.svcpart
1086 AND pkg_svc.pkgpart = $pkgpart
1089 AND 0 < ( SELECT count(*)
1091 LEFT JOIN cust_pkg using ( pkgnum )
1092 WHERE cust_svc.svcpart = part_svc.svcpart
1093 AND pkgnum = $pkgnum
1100 Returns a short status string for this package, currently:
1104 =item not yet billed
1106 =item one-time charge
1121 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1123 return 'cancelled' if $self->get('cancel');
1124 return 'suspended' if $self->susp;
1125 return 'not yet billed' unless $self->setup;
1126 return 'one-time charge' if $freq =~ /^(0|$)/;
1132 Class method that returns the list of possible status strings for packages
1133 (see L<the status method|/status>). For example:
1135 @statuses = FS::cust_pkg->statuses();
1139 tie my %statuscolor, 'Tie::IxHash',
1140 'not yet billed' => '000000',
1141 'one-time charge' => '000000',
1142 'active' => '00CC00',
1143 'suspended' => 'FF9900',
1144 'cancelled' => 'FF0000',
1148 my $self = shift; #could be class...
1149 grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1150 # mayble split btw one-time vs. recur
1156 Returns a hex triplet color string for this package's status.
1162 $statuscolor{$self->status};
1167 Returns a list of lists, calling the label method for all services
1168 (see L<FS::cust_svc>) of this billing item.
1174 map { [ $_->label ] } $self->cust_svc;
1177 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1179 Like the labels method, but returns historical information on services that
1180 were active as of END_TIMESTAMP and (optionally) not cancelled before
1183 Returns a list of lists, calling the label method for all (historical) services
1184 (see L<FS::h_cust_svc>) of this billing item.
1190 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1193 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1195 Like h_labels, except returns a simple flat list, and shortens long
1196 (currently >5) lists of identical services to one line that lists the service
1197 label and the number of individual services rather than individual items.
1201 sub h_labels_short {
1205 #tie %labels, 'Tie::IxHash';
1206 push @{ $labels{$_->[0]} }, $_->[1]
1207 foreach $self->h_labels(@_);
1209 foreach my $label ( keys %labels ) {
1210 my @values = @{ $labels{$label} };
1211 my $num = scalar(@values);
1213 push @labels, "$label ($num)";
1215 push @labels, map { "$label: $_" } @values;
1225 Returns the parent customer object (see L<FS::cust_main>).
1231 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1234 =item seconds_since TIMESTAMP
1236 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1237 package have been online since TIMESTAMP, according to the session monitor.
1239 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1240 L<Time::Local> and L<Date::Parse> for conversion functions.
1245 my($self, $since) = @_;
1248 foreach my $cust_svc (
1249 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1251 $seconds += $cust_svc->seconds_since($since);
1258 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1260 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1261 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1264 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1265 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1271 sub seconds_since_sqlradacct {
1272 my($self, $start, $end) = @_;
1276 foreach my $cust_svc (
1278 my $part_svc = $_->part_svc;
1279 $part_svc->svcdb eq 'svc_acct'
1280 && scalar($part_svc->part_export('sqlradius'));
1283 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1290 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1292 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1293 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1297 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1298 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1303 sub attribute_since_sqlradacct {
1304 my($self, $start, $end, $attrib) = @_;
1308 foreach my $cust_svc (
1310 my $part_svc = $_->part_svc;
1311 $part_svc->svcdb eq 'svc_acct'
1312 && scalar($part_svc->part_export('sqlradius'));
1315 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1322 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1324 Transfers as many services as possible from this package to another package.
1326 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1327 object. The destination package must already exist.
1329 Services are moved only if the destination allows services with the correct
1330 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
1331 this option with caution! No provision is made for export differences
1332 between the old and new service definitions. Probably only should be used
1333 when your exports for all service definitions of a given svcdb are identical.
1334 (attempt a transfer without it first, to move all possible svcpart-matching
1337 Any services that can't be moved remain in the original package.
1339 Returns an error, if there is one; otherwise, returns the number of services
1340 that couldn't be moved.
1345 my ($self, $dest_pkgnum, %opt) = @_;
1351 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1352 $dest = $dest_pkgnum;
1353 $dest_pkgnum = $dest->pkgnum;
1355 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1358 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1360 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1361 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1364 foreach my $cust_svc ($dest->cust_svc) {
1365 $target{$cust_svc->svcpart}--;
1368 my %svcpart2svcparts = ();
1369 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1370 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1371 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1372 next if exists $svcpart2svcparts{$svcpart};
1373 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1374 $svcpart2svcparts{$svcpart} = [
1376 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
1378 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1379 'svcpart' => $_ } );
1381 $pkg_svc ? $pkg_svc->primary_svc : '',
1382 $pkg_svc ? $pkg_svc->quantity : 0,
1386 grep { $_ != $svcpart }
1388 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1390 warn "alternates for svcpart $svcpart: ".
1391 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1396 foreach my $cust_svc ($self->cust_svc) {
1397 if($target{$cust_svc->svcpart} > 0) {
1398 $target{$cust_svc->svcpart}--;
1399 my $new = new FS::cust_svc { $cust_svc->hash };
1400 $new->pkgnum($dest_pkgnum);
1401 my $error = $new->replace($cust_svc);
1402 return $error if $error;
1403 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1405 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1406 warn "alternates to consider: ".
1407 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1409 my @alternate = grep {
1410 warn "considering alternate svcpart $_: ".
1411 "$target{$_} available in new package\n"
1414 } @{$svcpart2svcparts{$cust_svc->svcpart}};
1416 warn "alternate(s) found\n" if $DEBUG;
1417 my $change_svcpart = $alternate[0];
1418 $target{$change_svcpart}--;
1419 my $new = new FS::cust_svc { $cust_svc->hash };
1420 $new->svcpart($change_svcpart);
1421 $new->pkgnum($dest_pkgnum);
1422 my $error = $new->replace($cust_svc);
1423 return $error if $error;
1436 This method is deprecated. See the I<depend_jobnum> option to the insert and
1437 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1444 local $SIG{HUP} = 'IGNORE';
1445 local $SIG{INT} = 'IGNORE';
1446 local $SIG{QUIT} = 'IGNORE';
1447 local $SIG{TERM} = 'IGNORE';
1448 local $SIG{TSTP} = 'IGNORE';
1449 local $SIG{PIPE} = 'IGNORE';
1451 my $oldAutoCommit = $FS::UID::AutoCommit;
1452 local $FS::UID::AutoCommit = 0;
1455 foreach my $cust_svc ( $self->cust_svc ) {
1456 #false laziness w/svc_Common::insert
1457 my $svc_x = $cust_svc->svc_x;
1458 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1459 my $error = $part_export->export_insert($svc_x);
1461 $dbh->rollback if $oldAutoCommit;
1467 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1474 =head1 CLASS METHODS
1480 Returns an SQL expression identifying recurring packages.
1484 sub recurring_sql { "
1485 '0' != ( select freq from part_pkg
1486 where cust_pkg.pkgpart = part_pkg.pkgpart )
1491 Returns an SQL expression identifying one-time packages.
1496 '0' = ( select freq from part_pkg
1497 where cust_pkg.pkgpart = part_pkg.pkgpart )
1502 Returns an SQL expression identifying active packages.
1507 ". $_[0]->recurring_sql(). "
1508 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1509 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1514 Returns an SQL expression identifying inactive packages (one-time packages
1515 that are otherwise unsuspended/uncancelled).
1519 sub inactive_sql { "
1520 ". $_[0]->onetime_sql(). "
1521 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1522 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1528 Returns an SQL expression identifying suspended packages.
1532 sub suspended_sql { susp_sql(@_); }
1534 #$_[0]->recurring_sql(). ' AND '.
1536 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1537 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
1544 Returns an SQL exprression identifying cancelled packages.
1548 sub cancelled_sql { cancel_sql(@_); }
1550 #$_[0]->recurring_sql(). ' AND '.
1551 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1554 =item search_sql HREF
1556 Returns a qsearch hash expression to search for parameters specified in HREF.
1557 Valid parameters are
1561 =item magic - /^(active|inactive|suspended|cancell?ed)$/
1562 =item status - /^(active|inactive|suspended|one-time charge|inactive|cancell?ed)$/
1564 =item pkgpart - list specified how?
1565 =item setup - arrayref of beginning and ending epoch date
1566 =item last_bill - arrayref of beginning and ending epoch date
1567 =item bill - arrayref of beginning and ending epoch date
1568 =item adjourn - arrayref of beginning and ending epoch date
1569 =item susp - arrayref of beginning and ending epoch date
1570 =item expire - arrayref of beginning and ending epoch date
1571 =item cancel - arrayref of beginning and ending epoch date
1572 =item query - /^(pkgnum/APKG_pkgnum)$/
1573 =item cust_fields - a value suited to passing to FS::UI::Web::cust_header
1574 =item CurrentUser - specifies the user for agent virtualization
1580 my ($class, $params) = @_;
1587 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
1596 if ( $params->{'magic'} eq 'active'
1597 || $params->{'status'} eq 'active' ) {
1599 push @where, FS::cust_pkg->active_sql();
1601 } elsif ( $params->{'magic'} eq 'inactive'
1602 || $params->{'status'} eq 'inactive' ) {
1604 push @where, FS::cust_pkg->inactive_sql();
1606 } elsif ( $params->{'magic'} eq 'suspended'
1607 || $params->{'status'} eq 'suspended' ) {
1609 push @where, FS::cust_pkg->suspended_sql();
1611 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
1612 || $params->{'status'} =~ /^cancell?ed$/ ) {
1614 push @where, FS::cust_pkg->cancelled_sql();
1616 } elsif ( $params->{'status'} =~ /^(one-time charge|inactive)$/ ) {
1618 push @where, FS::cust_pkg->inactive_sql();
1623 # parse package class
1626 #false lazinessish w/graph/cust_bill_pkg.cgi
1629 if ( exists($params->{'classnum'})
1630 && $params->{'classnum'} =~ /^(\d*)$/
1634 if ( $classnum ) { #a specific class
1635 push @where, "classnum = $classnum";
1637 #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
1638 #die "classnum $classnum not found!" unless $pkg_class[0];
1639 #$title .= $pkg_class[0]->classname.' ';
1641 } elsif ( $classnum eq '' ) { #the empty class
1643 push @where, "classnum IS NULL";
1644 #$title .= 'Empty class ';
1645 #@pkg_class = ( '(empty class)' );
1646 } elsif ( $classnum eq '0' ) {
1647 #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
1648 #push @pkg_class, '(empty class)';
1650 die "illegal classnum";
1659 my $pkgpart = join (' OR pkgpart=',
1660 grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'}));
1661 push @where, '(pkgpart=' . $pkgpart . ')' if $pkgpart;
1669 #false laziness w/report_cust_pkg.html
1672 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
1673 'active' => { 'susp'=>1, 'cancel'=>1 },
1674 'suspended' => { 'cancel' => 1 },
1679 foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
1681 next unless exists($params->{$field});
1683 my($beginning, $ending) = @{$params->{$field}};
1685 next if $beginning == 0 && $ending == 4294967295;
1688 "cust_pkg.$field IS NOT NULL",
1689 "cust_pkg.$field >= $beginning",
1690 "cust_pkg.$field <= $ending";
1692 $orderby ||= "ORDER BY cust_pkg.$field";
1696 $orderby ||= 'ORDER BY bill';
1699 # parse magic, legacy, etc.
1702 if ( $params->{'magic'} &&
1703 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
1706 $orderby = 'ORDER BY pkgnum';
1708 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
1709 push @where, "pkgpart = $1";
1712 } elsif ( $params->{'query'} eq 'pkgnum' ) {
1714 $orderby = 'ORDER BY pkgnum';
1716 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
1718 $orderby = 'ORDER BY pkgnum';
1721 SELECT count(*) FROM pkg_svc
1722 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
1723 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
1724 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
1725 AND cust_svc.svcpart = pkg_svc.svcpart
1732 # setup queries, links, subs, etc. for the search
1735 # here is the agent virtualization
1736 if ($params->{CurrentUser}) {
1738 qsearchs('access_user', { username => $params->{CurrentUser} });
1741 push @where, $access_user->agentnums_sql;
1746 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql;
1749 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
1751 my $addl_from = 'LEFT JOIN cust_main USING ( custnum ) '.
1752 'LEFT JOIN part_pkg USING ( pkgpart ) '.
1753 'LEFT JOIN pkg_class USING ( classnum ) ';
1755 my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
1758 'table' => 'cust_pkg',
1760 'select' => join(', ',
1762 ( map "part_pkg.$_", qw( pkg freq ) ),
1763 'pkg_class.classname',
1764 'cust_main.custnum as cust_main_custnum',
1765 FS::UI::Web::cust_sql_fields(
1766 $params->{'cust_fields'}
1769 'extra_sql' => "$extra_sql $orderby",
1770 'addl_from' => $addl_from,
1771 'count_query' => $count_query,
1780 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
1782 CUSTNUM is a customer (see L<FS::cust_main>)
1784 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1785 L<FS::part_pkg>) to order for this customer. Duplicates are of course
1788 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1789 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
1790 new billing items. An error is returned if this is not possible (see
1791 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
1794 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1795 newly-created cust_pkg objects.
1797 REFNUM, if specified, will specify the FS::pkg_referral record to be created
1798 and inserted. Multiple FS::pkg_referral records can be created by
1799 setting I<refnum> to an array reference of refnums or a hash reference with
1800 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
1801 record will be created corresponding to cust_main.refnum.
1806 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1808 my $conf = new FS::Conf;
1810 # Transactionize this whole mess
1811 local $SIG{HUP} = 'IGNORE';
1812 local $SIG{INT} = 'IGNORE';
1813 local $SIG{QUIT} = 'IGNORE';
1814 local $SIG{TERM} = 'IGNORE';
1815 local $SIG{TSTP} = 'IGNORE';
1816 local $SIG{PIPE} = 'IGNORE';
1818 my $oldAutoCommit = $FS::UID::AutoCommit;
1819 local $FS::UID::AutoCommit = 0;
1823 my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1824 return "Customer not found: $custnum" unless $cust_main;
1826 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1829 my $change = scalar(@old_cust_pkg) != 0;
1832 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
1836 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1838 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( setup );
1839 $hash{'setup'} = $time if $old_cust_pkg[0]->setup;
1841 $hash{'change_date'} = $time;
1842 $hash{"change_$_"} = $old_cust_pkg[0]->$_() foreach qw( pkgnum pkgpart );
1845 # Create the new packages.
1846 foreach my $pkgpart (@$pkgparts) {
1847 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1848 pkgpart => $pkgpart,
1852 $error = $cust_pkg->insert( 'change' => $change );
1854 $dbh->rollback if $oldAutoCommit;
1857 push @$return_cust_pkg, $cust_pkg;
1859 # $return_cust_pkg now contains refs to all of the newly
1862 # Transfer services and cancel old packages.
1863 foreach my $old_pkg (@old_cust_pkg) {
1865 foreach my $new_pkg (@$return_cust_pkg) {
1866 $error = $old_pkg->transfer($new_pkg);
1867 if ($error and $error == 0) {
1868 # $old_pkg->transfer failed.
1869 $dbh->rollback if $oldAutoCommit;
1874 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1875 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1876 foreach my $new_pkg (@$return_cust_pkg) {
1877 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1878 if ($error and $error == 0) {
1879 # $old_pkg->transfer failed.
1880 $dbh->rollback if $oldAutoCommit;
1887 # Transfers were successful, but we went through all of the
1888 # new packages and still had services left on the old package.
1889 # We can't cancel the package under the circumstances, so abort.
1890 $dbh->rollback if $oldAutoCommit;
1891 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1893 $error = $old_pkg->cancel( quiet=>1 );
1899 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1905 Associates this package with a (suspension or cancellation) reason (see
1906 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
1909 Available options are:
1913 =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.
1919 If there is an error, returns the error, otherwise returns false.
1923 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
1925 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1926 L<FS::part_pkg>) to order for this customer. Duplicates are of course
1929 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
1930 replace. The services (see L<FS::cust_svc>) are moved to the
1931 new billing items. An error is returned if this is not possible (see
1934 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1935 newly-created cust_pkg objects.
1940 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1942 # Transactionize this whole mess
1943 local $SIG{HUP} = 'IGNORE';
1944 local $SIG{INT} = 'IGNORE';
1945 local $SIG{QUIT} = 'IGNORE';
1946 local $SIG{TERM} = 'IGNORE';
1947 local $SIG{TSTP} = 'IGNORE';
1948 local $SIG{PIPE} = 'IGNORE';
1950 my $oldAutoCommit = $FS::UID::AutoCommit;
1951 local $FS::UID::AutoCommit = 0;
1955 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1958 while(scalar(@old_cust_pkg)) {
1960 my $custnum = $old_cust_pkg[0]->custnum;
1961 my (@remove) = map { $_->pkgnum }
1962 grep { $_->custnum == $custnum } @old_cust_pkg;
1963 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
1965 my $error = order $custnum, $pkgparts, \@remove, \@return;
1967 push @errors, $error
1969 push @$return_cust_pkg, @return;
1972 if (scalar(@errors)) {
1973 $dbh->rollback if $oldAutoCommit;
1974 return join(' / ', @errors);
1977 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1982 my ($self, %options) = @_;
1984 my $otaker = $FS::CurrentUser::CurrentUser->username;
1987 if ( $options{'reason'} =~ /^(\d+)$/ ) {
1991 } elsif ( ref($options{'reason'}) ) {
1993 return 'Enter a new reason (or select an existing one)'
1994 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
1996 my $reason = new FS::reason({
1997 'reason_type' => $options{'reason'}->{'typenum'},
1998 'reason' => $options{'reason'}->{'reason'},
2000 my $error = $reason->insert;
2001 return $error if $error;
2003 $reasonnum = $reason->reasonnum;
2006 return "Unparsable reason: ". $options{'reason'};
2009 my $cust_pkg_reason =
2010 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
2011 'reasonnum' => $reasonnum,
2012 'otaker' => $otaker,
2013 'date' => $options{'date'}
2018 $cust_pkg_reason->insert;
2021 =item set_usage USAGE_VALUE_HASHREF
2023 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2024 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2025 upbytes, downbytes, and totalbytes are appropriate keys.
2027 All svc_accts which are part of this package have their values reset.
2032 my ($self, $valueref) = @_;
2034 foreach my $cust_svc ($self->cust_svc){
2035 my $svc_x = $cust_svc->svc_x;
2036 $svc_x->set_usage($valueref)
2037 if $svc_x->can("set_usage");
2041 =item recharge USAGE_VALUE_HASHREF
2043 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2044 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2045 upbytes, downbytes, and totalbytes are appropriate keys.
2047 All svc_accts which are part of this package have their values incremented.
2052 my ($self, $valueref) = @_;
2054 foreach my $cust_svc ($self->cust_svc){
2055 my $svc_x = $cust_svc->svc_x;
2056 $svc_x->recharge($valueref)
2057 if $svc_x->can("recharge");
2065 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
2067 In sub order, the @pkgparts array (passed by reference) is clobbered.
2069 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
2070 method to pass dates to the recur_prog expression, it should do so.
2072 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
2073 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
2074 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
2075 configuration values. Probably need a subroutine which decides what to do
2076 based on whether or not we've fetched the user yet, rather than a hash. See
2077 FS::UID and the TODO.
2079 Now that things are transactional should the check in the insert method be
2084 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
2085 L<FS::pkg_svc>, schema.html from the base documentation