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 );
10 use FS::cust_main_Mixin;
16 use FS::cust_bill_pkg;
20 use FS::cust_pkg_reason;
23 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
25 # because they load configuration by setting FS::UID::callback (see TODO)
31 # for sending cancel emails in sub cancel
34 @ISA = qw( FS::cust_main_Mixin FS::option_Common FS::Record );
38 $disable_agentcheck = 0;
42 my ( $hashref, $cache ) = @_;
43 #if ( $hashref->{'pkgpart'} ) {
44 if ( $hashref->{'pkg'} ) {
45 # #@{ $self->{'_pkgnum'} } = ();
46 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
47 # $self->{'_pkgpart'} = $subcache;
48 # #push @{ $self->{'_pkgnum'} },
49 # FS::part_pkg->new_or_cached($hashref, $subcache);
50 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
52 if ( exists $hashref->{'svcnum'} ) {
53 #@{ $self->{'_pkgnum'} } = ();
54 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
55 $self->{'_svcnum'} = $subcache;
56 #push @{ $self->{'_pkgnum'} },
57 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
63 FS::cust_pkg - Object methods for cust_pkg objects
69 $record = new FS::cust_pkg \%hash;
70 $record = new FS::cust_pkg { 'column' => 'value' };
72 $error = $record->insert;
74 $error = $new_record->replace($old_record);
76 $error = $record->delete;
78 $error = $record->check;
80 $error = $record->cancel;
82 $error = $record->suspend;
84 $error = $record->unsuspend;
86 $part_pkg = $record->part_pkg;
88 @labels = $record->labels;
90 $seconds = $record->seconds_since($timestamp);
92 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
93 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
97 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
98 inherits from FS::Record. The following fields are currently supported:
102 =item pkgnum - primary key (assigned automatically for new billing items)
104 =item custnum - Customer (see L<FS::cust_main>)
106 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
110 =item bill - date (next bill date)
112 =item last_bill - last bill date
122 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
124 =item manual_flag - If this field is set to 1, disables the automatic
125 unsuspension of this package when using the B<unsuspendauto> config file.
129 Note: setup, bill, adjourn, susp, expire and cancel are specified as UNIX timestamps;
130 see L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for
131 conversion functions.
139 Create a new billing item. To add the item to the database, see L<"insert">.
143 sub table { 'cust_pkg'; }
144 sub cust_linked { $_[0]->cust_main_custnum; }
145 sub cust_unlinked_msg {
147 "WARNING: can't find cust_main.custnum ". $self->custnum.
148 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
151 =item insert [ OPTION => VALUE ... ]
153 Adds this billing item to the database ("Orders" the item). If there is an
154 error, returns the error, otherwise returns false.
156 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
157 will be used to look up the package definition and agent restrictions will be
160 The following options are available: I<change>
162 I<change>, if set true, supresses any referral credit to a referring customer.
167 my( $self, %options ) = @_;
169 local $SIG{HUP} = 'IGNORE';
170 local $SIG{INT} = 'IGNORE';
171 local $SIG{QUIT} = 'IGNORE';
172 local $SIG{TERM} = 'IGNORE';
173 local $SIG{TSTP} = 'IGNORE';
174 local $SIG{PIPE} = 'IGNORE';
176 my $oldAutoCommit = $FS::UID::AutoCommit;
177 local $FS::UID::AutoCommit = 0;
180 my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
182 $dbh->rollback if $oldAutoCommit;
186 #if ( $self->reg_code ) {
187 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
188 # $error = $reg_code->delete;
190 # $dbh->rollback if $oldAutoCommit;
195 my $conf = new FS::Conf;
196 my $cust_main = $self->cust_main;
197 my $part_pkg = $self->part_pkg;
198 if ( $conf->exists('referral_credit')
199 && $cust_main->referral_custnum
200 && ! $options{'change'}
201 && $part_pkg->freq !~ /^0\D?$/
204 my $referring_cust_main = $cust_main->referring_cust_main;
205 if ( $referring_cust_main->status ne 'cancelled' ) {
207 if ( $part_pkg->freq !~ /^\d+$/ ) {
208 warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum.
209 ' for package '. $self->pkgnum.
210 ' ( customer '. $self->custnum. ')'.
211 ' - One-time referral credits not (yet) available for '.
212 ' packages with '. $part_pkg->freq_pretty. ' frequency';
215 my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
217 $referring_cust_main->credit( $amount,
218 'Referral credit for '. $cust_main->name
221 $dbh->rollback if $oldAutoCommit;
222 return "Error crediting customer ". $cust_main->referral_custnum.
223 " for referral: $error";
231 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
232 my $queue = new FS::queue {
233 'job' => 'FS::cust_main::queueable_print',
235 $error = $queue->insert(
236 'custnum' => $self->custnum,
237 'template' => 'welcome_letter',
241 warn "can't send welcome letter: $error";
246 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
253 This method now works but you probably shouldn't use it.
255 You don't want to delete billing items, because there would then be no record
256 the customer ever purchased the item. Instead, see the cancel method.
261 # return "Can't delete cust_pkg records!";
264 =item replace OLD_RECORD
266 Replaces the OLD_RECORD with this one in the database. If there is an error,
267 returns the error, otherwise returns false.
269 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
271 Changing pkgpart may have disasterous effects. See the order subroutine.
273 setup and bill are normally updated by calling the bill method of a customer
274 object (see L<FS::cust_main>).
276 suspend is normally updated by the suspend and unsuspend methods.
278 cancel is normally updated by the cancel method (and also the order subroutine
286 my( $new, $old, %options ) = @_;
288 # We absolutely have to have an old vs. new record to make this work.
289 if (!defined($old)) {
290 $old = qsearchs( 'cust_pkg', { 'pkgnum' => $new->pkgnum } );
292 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
293 return "Can't change otaker!" if $old->otaker ne $new->otaker;
296 #return "Can't change setup once it exists!"
297 # if $old->getfield('setup') &&
298 # $old->getfield('setup') != $new->getfield('setup');
300 #some logic for bill, susp, cancel?
302 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
304 local $SIG{HUP} = 'IGNORE';
305 local $SIG{INT} = 'IGNORE';
306 local $SIG{QUIT} = 'IGNORE';
307 local $SIG{TERM} = 'IGNORE';
308 local $SIG{TSTP} = 'IGNORE';
309 local $SIG{PIPE} = 'IGNORE';
311 my $oldAutoCommit = $FS::UID::AutoCommit;
312 local $FS::UID::AutoCommit = 0;
315 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
316 if ($options{'reason'} && $new->$method && $old->$method ne $new->$method) {
317 my $error = $new->insert_reason( 'reason' => $options{'reason'},
318 'date' => $new->$method,
321 dbh->rollback if $oldAutoCommit;
322 return "Error inserting cust_pkg_reason: $error";
327 #save off and freeze RADIUS attributes for any associated svc_acct records
329 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
331 #also check for specific exports?
332 # to avoid spurious modify export events
333 @svc_acct = map { $_->svc_x }
334 grep { $_->part_svc->svcdb eq 'svc_acct' }
337 $_->snapshot foreach @svc_acct;
341 my $error = $new->SUPER::replace($old,
342 $options{options} ? ${options{options}} : ()
345 $dbh->rollback if $oldAutoCommit;
349 #for prepaid packages,
350 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
351 foreach my $old_svc_acct ( @svc_acct ) {
352 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
353 my $s_error = $new_svc_acct->replace($old_svc_acct);
355 $dbh->rollback if $oldAutoCommit;
360 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
367 Checks all fields to make sure this is a valid billing item. If there is an
368 error, returns the error, otherwise returns false. Called by the insert and
377 $self->ut_numbern('pkgnum')
378 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
379 || $self->ut_numbern('pkgpart')
380 || $self->ut_numbern('setup')
381 || $self->ut_numbern('bill')
382 || $self->ut_numbern('susp')
383 || $self->ut_numbern('cancel')
384 || $self->ut_numbern('adjourn')
385 || $self->ut_numbern('expire')
387 return $error if $error;
389 if ( $self->reg_code ) {
391 unless ( grep { $self->pkgpart == $_->pkgpart }
392 map { $_->reg_code_pkg }
393 qsearchs( 'reg_code', { 'code' => $self->reg_code,
394 'agentnum' => $self->cust_main->agentnum })
396 return "Unknown registration code";
399 } elsif ( $self->promo_code ) {
402 qsearchs('part_pkg', {
403 'pkgpart' => $self->pkgpart,
404 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
406 return 'Unknown promotional code' unless $promo_part_pkg;
410 unless ( $disable_agentcheck ) {
412 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
413 my $pkgpart_href = $agent->pkgpart_hashref;
414 return "agent ". $agent->agentnum.
415 " can't purchase pkgpart ". $self->pkgpart
416 unless $pkgpart_href->{ $self->pkgpart };
419 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
420 return $error if $error;
424 $self->otaker(getotaker) unless $self->otaker;
425 $self->otaker =~ /^([\w\.\-]{0,16})$/ or return "Illegal otaker";
428 if ( $self->dbdef_table->column('manual_flag') ) {
429 $self->manual_flag('') if $self->manual_flag eq ' ';
430 $self->manual_flag =~ /^([01]?)$/
431 or return "Illegal manual_flag ". $self->manual_flag;
432 $self->manual_flag($1);
438 =item cancel [ OPTION => VALUE ... ]
440 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
441 in this package, then cancels the package itself (sets the cancel field to
444 Available options are: I<quiet>
446 I<quiet> can be set true to supress email cancellation notices.
448 If there is an error, returns the error, otherwise returns false.
453 my( $self, %options ) = @_;
456 local $SIG{HUP} = 'IGNORE';
457 local $SIG{INT} = 'IGNORE';
458 local $SIG{QUIT} = 'IGNORE';
459 local $SIG{TERM} = 'IGNORE';
460 local $SIG{TSTP} = 'IGNORE';
461 local $SIG{PIPE} = 'IGNORE';
463 my $oldAutoCommit = $FS::UID::AutoCommit;
464 local $FS::UID::AutoCommit = 0;
467 if ($options{'reason'}) {
468 $error = $self->insert_reason( 'reason' => $options{'reason'} );
470 dbh->rollback if $oldAutoCommit;
471 return "Error inserting cust_pkg_reason: $error";
476 foreach my $cust_svc (
479 sort { $a->[1] <=> $b->[1] }
480 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
481 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
484 my $error = $cust_svc->cancel;
487 $dbh->rollback if $oldAutoCommit;
488 return "Error cancelling cust_svc: $error";
492 # Add a credit for remaining service
493 my $remaining_value = $self->calc_remain();
494 if ( $remaining_value > 0 ) {
495 my $error = $self->cust_main->credit(
497 'Credit for unused time on '. $self->part_pkg->pkg,
500 $dbh->rollback if $oldAutoCommit;
501 return "Error crediting customer \$$remaining_value for unused time on".
502 $self->part_pkg->pkg. ": $error";
506 unless ( $self->getfield('cancel') ) {
507 my %hash = $self->hash;
508 $hash{'cancel'} = time;
509 my $new = new FS::cust_pkg ( \%hash );
510 $error = $new->replace( $self, options => { $self->options } );
512 $dbh->rollback if $oldAutoCommit;
517 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
519 my $conf = new FS::Conf;
520 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
521 if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
522 my $conf = new FS::Conf;
523 my $error = send_email(
524 'from' => $conf->config('invoice_from'),
525 'to' => \@invoicing_list,
526 'subject' => $conf->config('cancelsubject'),
527 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
529 #should this do something on errors?
538 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
539 package, then suspends the package itself (sets the susp field to now).
541 If there is an error, returns the error, otherwise returns false.
546 my( $self, %options ) = @_;
549 local $SIG{HUP} = 'IGNORE';
550 local $SIG{INT} = 'IGNORE';
551 local $SIG{QUIT} = 'IGNORE';
552 local $SIG{TERM} = 'IGNORE';
553 local $SIG{TSTP} = 'IGNORE';
554 local $SIG{PIPE} = 'IGNORE';
556 my $oldAutoCommit = $FS::UID::AutoCommit;
557 local $FS::UID::AutoCommit = 0;
560 if ($options{'reason'}) {
561 $error = $self->insert_reason( 'reason' => $options{'reason'} );
563 dbh->rollback if $oldAutoCommit;
564 return "Error inserting cust_pkg_reason: $error";
568 foreach my $cust_svc (
569 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
571 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
573 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
574 $dbh->rollback if $oldAutoCommit;
575 return "Illegal svcdb value in part_svc!";
578 require "FS/$svcdb.pm";
580 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
582 $error = $svc->suspend;
584 $dbh->rollback if $oldAutoCommit;
591 unless ( $self->getfield('susp') ) {
592 my %hash = $self->hash;
593 $hash{'susp'} = time;
594 my $new = new FS::cust_pkg ( \%hash );
595 $error = $new->replace( $self, options => { $self->options } );
597 $dbh->rollback if $oldAutoCommit;
602 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
607 =item unsuspend [ OPTION => VALUE ... ]
609 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
610 package, then unsuspends the package itself (clears the susp field and the
611 adjourn field if it is in the past).
613 Available options are: I<adjust_next_bill>.
615 I<adjust_next_bill> can be set true to adjust the next bill date forward by
616 the amount of time the account was inactive. This was set true by default
617 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
618 explicitly requested. Price plans for which this makes sense (anniversary-date
619 based than prorate or subscription) could have an option to enable this
622 If there is an error, returns the error, otherwise returns false.
627 my( $self, %opt ) = @_;
630 local $SIG{HUP} = 'IGNORE';
631 local $SIG{INT} = 'IGNORE';
632 local $SIG{QUIT} = 'IGNORE';
633 local $SIG{TERM} = 'IGNORE';
634 local $SIG{TSTP} = 'IGNORE';
635 local $SIG{PIPE} = 'IGNORE';
637 my $oldAutoCommit = $FS::UID::AutoCommit;
638 local $FS::UID::AutoCommit = 0;
641 foreach my $cust_svc (
642 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
644 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
646 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
647 $dbh->rollback if $oldAutoCommit;
648 return "Illegal svcdb value in part_svc!";
651 require "FS/$svcdb.pm";
653 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
655 $error = $svc->unsuspend;
657 $dbh->rollback if $oldAutoCommit;
664 unless ( ! $self->getfield('susp') ) {
665 my %hash = $self->hash;
666 my $inactive = time - $hash{'susp'};
668 my $conf = new FS::Conf;
670 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
671 if ( $opt{'adjust_next_bill'}
672 || $conf->config('unsuspend-always_adjust_next_bill_date') )
673 && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
676 $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
677 my $new = new FS::cust_pkg ( \%hash );
678 $error = $new->replace( $self, options => { $self->options } );
680 $dbh->rollback if $oldAutoCommit;
685 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
692 Returns the last bill date, or if there is no last bill date, the setup date.
693 Useful for billing metered services.
699 if ( $self->dbdef_table->column('last_bill') ) {
700 return $self->setfield('last_bill', $_[0]) if @_;
701 return $self->getfield('last_bill') if $self->getfield('last_bill');
703 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
704 'edate' => $self->bill, } );
705 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
710 Returns the most recent FS::reason associated with the package.
716 my $cust_pkg_reason = qsearchs( {
717 'table' => 'cust_pkg_reason',
718 'hashref' => { 'pkgnum' => $self->pkgnum, },
719 'extra_sql'=> 'ORDER BY date DESC LIMIT 1',
721 qsearchs ( 'reason', { 'reasonnum' => $cust_pkg_reason->reasonnum } )
727 Returns the definition for this billing item, as an FS::part_pkg object (see
734 #exists( $self->{'_pkgpart'} )
736 ? $self->{'_pkgpart'}
737 : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
742 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
749 $self->part_pkg->calc_setup($self, @_);
754 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
761 $self->part_pkg->calc_recur($self, @_);
766 Calls the I<calc_remain> of the FS::part_pkg object associated with this
773 $self->part_pkg->calc_remain($self, @_);
778 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
785 $self->part_pkg->calc_cancel($self, @_);
790 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
796 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
799 =item cust_svc [ SVCPART ]
801 Returns the services for this package, as FS::cust_svc objects (see
802 L<FS::cust_svc>). If a svcpart is specified, return only the matching
811 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
812 'svcpart' => shift, } );
815 #if ( $self->{'_svcnum'} ) {
816 # values %{ $self->{'_svcnum'}->cache };
818 $self->_sort_cust_svc(
819 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
825 =item overlimit [ SVCPART ]
827 Returns the services for this package which have exceeded their
828 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
829 is specified, return only the matching services.
835 grep { $_->overlimit } $self->cust_svc;
838 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
840 Returns historical services for this package created before END TIMESTAMP and
841 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
842 (see L<FS::h_cust_svc>).
849 $self->_sort_cust_svc(
850 [ qsearch( 'h_cust_svc',
851 { 'pkgnum' => $self->pkgnum, },
852 FS::h_cust_svc->sql_h_search(@_),
859 my( $self, $arrayref ) = @_;
862 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
864 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
865 'svcpart' => $_->svcpart } );
867 $pkg_svc ? $pkg_svc->primary_svc : '',
868 $pkg_svc ? $pkg_svc->quantity : 0,
875 =item num_cust_svc [ SVCPART ]
877 Returns the number of provisioned services for this package. If a svcpart is
878 specified, counts only the matching services.
884 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
885 $sql .= ' AND svcpart = ?' if @_;
886 my $sth = dbh->prepare($sql) or die dbh->errstr;
887 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
888 $sth->fetchrow_arrayref->[0];
891 =item available_part_svc
893 Returns a list of FS::part_svc objects representing services included in this
894 package but not yet provisioned. Each FS::part_svc object also has an extra
895 field, I<num_avail>, which specifies the number of available services.
899 sub available_part_svc {
901 grep { $_->num_avail > 0 }
903 my $part_svc = $_->part_svc;
904 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
905 $_->quantity - $self->num_cust_svc($_->svcpart);
908 $self->part_pkg->pkg_svc;
913 Returns a list of FS::part_svc objects representing provisioned and available
914 services included in this package. Each FS::part_svc object also has the
915 following extra fields:
919 =item num_cust_svc (count)
921 =item num_avail (quantity - count)
923 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
926 label -> ($cust_svc->label)[1]
935 #XXX some sort of sort order besides numeric by svcpart...
936 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
938 my $part_svc = $pkg_svc->part_svc;
939 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
940 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
941 $part_svc->{'Hash'}{'num_avail'} =
942 max( 0, $pkg_svc->quantity - $num_cust_svc );
943 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
945 } $self->part_pkg->pkg_svc;
948 push @part_svc, map {
950 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
951 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
952 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
953 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
955 } $self->extra_part_svc;
963 Returns a list of FS::part_svc objects corresponding to services in this
964 package which are still provisioned but not (any longer) available in the
972 my $pkgnum = $self->pkgnum;
973 my $pkgpart = $self->pkgpart;
976 'table' => 'part_svc',
978 'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
979 WHERE pkg_svc.svcpart = part_svc.svcpart
980 AND pkg_svc.pkgpart = $pkgpart
983 AND 0 < ( SELECT count(*)
985 LEFT JOIN cust_pkg using ( pkgnum )
986 WHERE cust_svc.svcpart = part_svc.svcpart
994 Returns a short status string for this package, currently:
1000 =item one-time charge
1015 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1017 return 'cancelled' if $self->get('cancel');
1018 return 'suspended' if $self->susp;
1019 return 'not yet billed' unless $self->setup;
1020 return 'one-time charge' if $freq =~ /^(0|$)/;
1026 Class method that returns the list of possible status strings for pacakges
1027 (see L<the status method|/status>). For example:
1029 @statuses = FS::cust_pkg->statuses();
1033 tie my %statuscolor, 'Tie::IxHash',
1034 'not yet billed' => '000000',
1035 'one-time charge' => '000000',
1036 'active' => '00CC00',
1037 'suspended' => 'FF9900',
1038 'cancelled' => 'FF0000',
1042 my $self = shift; #could be class...
1043 grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1044 # mayble split btw one-time vs. recur
1050 Returns a hex triplet color string for this package's status.
1056 $statuscolor{$self->status};
1061 Returns a list of lists, calling the label method for all services
1062 (see L<FS::cust_svc>) of this billing item.
1068 map { [ $_->label ] } $self->cust_svc;
1071 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1073 Like the labels method, but returns historical information on services that
1074 were active as of END_TIMESTAMP and (optionally) not cancelled before
1077 Returns a list of lists, calling the label method for all (historical) services
1078 (see L<FS::h_cust_svc>) of this billing item.
1084 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1087 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1089 Like h_labels, except returns a simple flat list, and shortens long
1090 (currently >5) lists of identical services to one line that lists the service
1091 label and the number of individual services rather than individual items.
1095 sub h_labels_short {
1099 #tie %labels, 'Tie::IxHash';
1100 push @{ $labels{$_->[0]} }, $_->[1]
1101 foreach $self->h_labels(@_);
1103 foreach my $label ( keys %labels ) {
1104 my @values = @{ $labels{$label} };
1105 my $num = scalar(@values);
1107 push @labels, "$label ($num)";
1109 push @labels, map { "$label: $_" } @values;
1119 Returns the parent customer object (see L<FS::cust_main>).
1125 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1128 =item seconds_since TIMESTAMP
1130 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1131 package have been online since TIMESTAMP, according to the session monitor.
1133 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1134 L<Time::Local> and L<Date::Parse> for conversion functions.
1139 my($self, $since) = @_;
1142 foreach my $cust_svc (
1143 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1145 $seconds += $cust_svc->seconds_since($since);
1152 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1154 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1155 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1158 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1159 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1165 sub seconds_since_sqlradacct {
1166 my($self, $start, $end) = @_;
1170 foreach my $cust_svc (
1172 my $part_svc = $_->part_svc;
1173 $part_svc->svcdb eq 'svc_acct'
1174 && scalar($part_svc->part_export('sqlradius'));
1177 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1184 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1186 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1187 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1191 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1192 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1197 sub attribute_since_sqlradacct {
1198 my($self, $start, $end, $attrib) = @_;
1202 foreach my $cust_svc (
1204 my $part_svc = $_->part_svc;
1205 $part_svc->svcdb eq 'svc_acct'
1206 && scalar($part_svc->part_export('sqlradius'));
1209 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1216 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1218 Transfers as many services as possible from this package to another package.
1220 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1221 object. The destination package must already exist.
1223 Services are moved only if the destination allows services with the correct
1224 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
1225 this option with caution! No provision is made for export differences
1226 between the old and new service definitions. Probably only should be used
1227 when your exports for all service definitions of a given svcdb are identical.
1228 (attempt a transfer without it first, to move all possible svcpart-matching
1231 Any services that can't be moved remain in the original package.
1233 Returns an error, if there is one; otherwise, returns the number of services
1234 that couldn't be moved.
1239 my ($self, $dest_pkgnum, %opt) = @_;
1245 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1246 $dest = $dest_pkgnum;
1247 $dest_pkgnum = $dest->pkgnum;
1249 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1252 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1254 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1255 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1258 foreach my $cust_svc ($dest->cust_svc) {
1259 $target{$cust_svc->svcpart}--;
1262 my %svcpart2svcparts = ();
1263 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1264 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1265 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1266 next if exists $svcpart2svcparts{$svcpart};
1267 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1268 $svcpart2svcparts{$svcpart} = [
1270 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
1272 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1273 'svcpart' => $_ } );
1275 $pkg_svc ? $pkg_svc->primary_svc : '',
1276 $pkg_svc ? $pkg_svc->quantity : 0,
1280 grep { $_ != $svcpart }
1282 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1284 warn "alternates for svcpart $svcpart: ".
1285 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1290 foreach my $cust_svc ($self->cust_svc) {
1291 if($target{$cust_svc->svcpart} > 0) {
1292 $target{$cust_svc->svcpart}--;
1293 my $new = new FS::cust_svc { $cust_svc->hash };
1294 $new->pkgnum($dest_pkgnum);
1295 my $error = $new->replace($cust_svc);
1296 return $error if $error;
1297 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1299 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1300 warn "alternates to consider: ".
1301 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1303 my @alternate = grep {
1304 warn "considering alternate svcpart $_: ".
1305 "$target{$_} available in new package\n"
1308 } @{$svcpart2svcparts{$cust_svc->svcpart}};
1310 warn "alternate(s) found\n" if $DEBUG;
1311 my $change_svcpart = $alternate[0];
1312 $target{$change_svcpart}--;
1313 my $new = new FS::cust_svc { $cust_svc->hash };
1314 $new->svcpart($change_svcpart);
1315 $new->pkgnum($dest_pkgnum);
1316 my $error = $new->replace($cust_svc);
1317 return $error if $error;
1330 This method is deprecated. See the I<depend_jobnum> option to the insert and
1331 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1338 local $SIG{HUP} = 'IGNORE';
1339 local $SIG{INT} = 'IGNORE';
1340 local $SIG{QUIT} = 'IGNORE';
1341 local $SIG{TERM} = 'IGNORE';
1342 local $SIG{TSTP} = 'IGNORE';
1343 local $SIG{PIPE} = 'IGNORE';
1345 my $oldAutoCommit = $FS::UID::AutoCommit;
1346 local $FS::UID::AutoCommit = 0;
1349 foreach my $cust_svc ( $self->cust_svc ) {
1350 #false laziness w/svc_Common::insert
1351 my $svc_x = $cust_svc->svc_x;
1352 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1353 my $error = $part_export->export_insert($svc_x);
1355 $dbh->rollback if $oldAutoCommit;
1361 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1368 =head1 CLASS METHODS
1374 Returns an SQL expression identifying recurring packages.
1378 sub recurring_sql { "
1379 '0' != ( select freq from part_pkg
1380 where cust_pkg.pkgpart = part_pkg.pkgpart )
1385 Returns an SQL expression identifying one-time packages.
1390 '0' = ( select freq from part_pkg
1391 where cust_pkg.pkgpart = part_pkg.pkgpart )
1396 Returns an SQL expression identifying active packages.
1401 ". $_[0]->recurring_sql(). "
1402 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1403 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1408 Returns an SQL expression identifying inactive packages (one-time packages
1409 that are otherwise unsuspended/uncancelled).
1413 sub inactive_sql { "
1414 ". $_[0]->onetime_sql(). "
1415 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1416 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1422 Returns an SQL expression identifying suspended packages.
1426 sub suspended_sql { susp_sql(@_); }
1428 #$_[0]->recurring_sql(). ' AND '.
1430 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1431 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
1438 Returns an SQL exprression identifying cancelled packages.
1442 sub cancelled_sql { cancel_sql(@_); }
1444 #$_[0]->recurring_sql(). ' AND '.
1445 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1452 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1454 CUSTNUM is a customer (see L<FS::cust_main>)
1456 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1457 L<FS::part_pkg>) to order for this customer. Duplicates are of course
1460 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1461 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
1462 new billing items. An error is returned if this is not possible (see
1463 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
1466 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1467 newly-created cust_pkg objects.
1472 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1474 my $conf = new FS::Conf;
1476 # Transactionize this whole mess
1477 local $SIG{HUP} = 'IGNORE';
1478 local $SIG{INT} = 'IGNORE';
1479 local $SIG{QUIT} = 'IGNORE';
1480 local $SIG{TERM} = 'IGNORE';
1481 local $SIG{TSTP} = 'IGNORE';
1482 local $SIG{PIPE} = 'IGNORE';
1484 my $oldAutoCommit = $FS::UID::AutoCommit;
1485 local $FS::UID::AutoCommit = 0;
1489 my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1490 return "Customer not found: $custnum" unless $cust_main;
1492 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1495 my $change = scalar(@old_cust_pkg) != 0;
1498 if ( scalar(@old_cust_pkg) == 1 ) {
1499 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1500 $hash{'setup'} = time;
1503 # Create the new packages.
1504 foreach my $pkgpart (@$pkgparts) {
1505 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1506 pkgpart => $pkgpart,
1509 $error = $cust_pkg->insert( 'change' => $change );
1511 $dbh->rollback if $oldAutoCommit;
1514 push @$return_cust_pkg, $cust_pkg;
1516 # $return_cust_pkg now contains refs to all of the newly
1519 # Transfer services and cancel old packages.
1520 foreach my $old_pkg (@old_cust_pkg) {
1522 foreach my $new_pkg (@$return_cust_pkg) {
1523 $error = $old_pkg->transfer($new_pkg);
1524 if ($error and $error == 0) {
1525 # $old_pkg->transfer failed.
1526 $dbh->rollback if $oldAutoCommit;
1531 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1532 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1533 foreach my $new_pkg (@$return_cust_pkg) {
1534 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1535 if ($error and $error == 0) {
1536 # $old_pkg->transfer failed.
1537 $dbh->rollback if $oldAutoCommit;
1544 # Transfers were successful, but we went through all of the
1545 # new packages and still had services left on the old package.
1546 # We can't cancel the package under the circumstances, so abort.
1547 $dbh->rollback if $oldAutoCommit;
1548 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1550 $error = $old_pkg->cancel( quiet=>1 );
1556 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1561 my ($self, %options) = @_;
1563 my $otaker = $FS::CurrentUser::CurrentUser->username;
1565 my $cust_pkg_reason =
1566 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
1567 'reasonnum' => $options{'reason'},
1568 'otaker' => $otaker,
1569 'date' => $options{'date'}
1573 return $cust_pkg_reason->insert;
1576 =item set_usage USAGE_VALUE_HASHREF
1578 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
1579 to which they should be set (see L<FS::svc_acct>). Currently seconds,
1580 upbytes, downbytes, and totalbytes are appropriate keys.
1582 All svc_accts which are part of this package have their values reset.
1587 my ($self, $valueref) = @_;
1589 foreach my $cust_svc ($self->cust_svc){
1590 my $svc_x = $cust_svc->svc_x;
1591 $svc_x->set_usage($valueref)
1592 if $svc_x->can("set_usage");
1600 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
1602 In sub order, the @pkgparts array (passed by reference) is clobbered.
1604 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
1605 method to pass dates to the recur_prog expression, it should do so.
1607 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1608 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1609 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1610 configuration values. Probably need a subroutine which decides what to do
1611 based on whether or not we've fetched the user yet, rather than a hash. See
1612 FS::UID and the TODO.
1614 Now that things are transactional should the check in the insert method be
1619 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1620 L<FS::pkg_svc>, schema.html from the base documentation