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
120 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
122 =item manual_flag - If this field is set to 1, disables the automatic
123 unsuspension of this package when using the B<unsuspendauto> config file.
127 Note: setup, bill, susp, expire and cancel are specified as UNIX timestamps;
128 see L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for
129 conversion functions.
137 Create a new billing item. To add the item to the database, see L<"insert">.
141 sub table { 'cust_pkg'; }
142 sub cust_linked { $_[0]->cust_main_custnum; }
143 sub cust_unlinked_msg {
145 "WARNING: can't find cust_main.custnum ". $self->custnum.
146 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
149 =item insert [ OPTION => VALUE ... ]
151 Adds this billing item to the database ("Orders" the item). If there is an
152 error, returns the error, otherwise returns false.
154 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
155 will be used to look up the package definition and agent restrictions will be
158 The following options are available: I<change>
160 I<change>, if set true, supresses any referral credit to a referring customer.
165 my( $self, %options ) = @_;
167 local $SIG{HUP} = 'IGNORE';
168 local $SIG{INT} = 'IGNORE';
169 local $SIG{QUIT} = 'IGNORE';
170 local $SIG{TERM} = 'IGNORE';
171 local $SIG{TSTP} = 'IGNORE';
172 local $SIG{PIPE} = 'IGNORE';
174 my $oldAutoCommit = $FS::UID::AutoCommit;
175 local $FS::UID::AutoCommit = 0;
178 my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
180 $dbh->rollback if $oldAutoCommit;
184 #if ( $self->reg_code ) {
185 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
186 # $error = $reg_code->delete;
188 # $dbh->rollback if $oldAutoCommit;
193 my $conf = new FS::Conf;
194 my $cust_main = $self->cust_main;
195 my $part_pkg = $self->part_pkg;
196 if ( $conf->exists('referral_credit')
197 && $cust_main->referral_custnum
198 && ! $options{'change'}
199 && $part_pkg->freq !~ /^0\D?$/
202 my $referring_cust_main = $cust_main->referring_cust_main;
203 if ( $referring_cust_main->status ne 'cancelled' ) {
205 if ( $part_pkg->freq !~ /^\d+$/ ) {
206 warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum.
207 ' for package '. $self->pkgnum.
208 ' ( customer '. $self->custnum. ')'.
209 ' - One-time referral credits not (yet) available for '.
210 ' packages with '. $part_pkg->freq_pretty. ' frequency';
213 my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
215 $referring_cust_main->credit( $amount,
216 'Referral credit for '. $cust_main->name
219 $dbh->rollback if $oldAutoCommit;
220 return "Error crediting customer ". $cust_main->referral_custnum.
221 " for referral: $error";
229 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
236 This method now works but you probably shouldn't use it.
238 You don't want to delete billing items, because there would then be no record
239 the customer ever purchased the item. Instead, see the cancel method.
244 # return "Can't delete cust_pkg records!";
247 =item replace OLD_RECORD
249 Replaces the OLD_RECORD with this one in the database. If there is an error,
250 returns the error, otherwise returns false.
252 Currently, custnum, setup, bill, susp, expire, and cancel may be changed.
254 Changing pkgpart may have disasterous effects. See the order subroutine.
256 setup and bill are normally updated by calling the bill method of a customer
257 object (see L<FS::cust_main>).
259 suspend is normally updated by the suspend and unsuspend methods.
261 cancel is normally updated by the cancel method (and also the order subroutine
269 my( $new, $old, %options ) = @_;
271 # We absolutely have to have an old vs. new record to make this work.
272 if (!defined($old)) {
273 $old = qsearchs( 'cust_pkg', { 'pkgnum' => $new->pkgnum } );
275 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
276 return "Can't change otaker!" if $old->otaker ne $new->otaker;
279 #return "Can't change setup once it exists!"
280 # if $old->getfield('setup') &&
281 # $old->getfield('setup') != $new->getfield('setup');
283 #some logic for bill, susp, cancel?
285 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
287 local $SIG{HUP} = 'IGNORE';
288 local $SIG{INT} = 'IGNORE';
289 local $SIG{QUIT} = 'IGNORE';
290 local $SIG{TERM} = 'IGNORE';
291 local $SIG{TSTP} = 'IGNORE';
292 local $SIG{PIPE} = 'IGNORE';
294 my $oldAutoCommit = $FS::UID::AutoCommit;
295 local $FS::UID::AutoCommit = 0;
298 if ($options{'reason'} && $new->expire && $old->expire ne $new->expire) {
299 my $error = $new->insert_reason( 'reason' => $options{'reason'},
300 'date' => $new->expire,
303 dbh->rollback if $oldAutoCommit;
304 return "Error inserting cust_pkg_reason: $error";
308 #save off and freeze RADIUS attributes for any associated svc_acct records
310 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
312 #also check for specific exports?
313 # to avoid spurious modify export events
314 @svc_acct = map { $_->svc_x }
315 grep { $_->part_svc->svcdb eq 'svc_acct' }
318 $_->snapshot foreach @svc_acct;
322 my $error = $new->SUPER::replace($old,
323 $options{options} ? ${options{options}} : ()
326 $dbh->rollback if $oldAutoCommit;
330 #for prepaid packages,
331 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
332 foreach my $old_svc_acct ( @svc_acct ) {
333 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
334 my $s_error = $new_svc_acct->replace($old_svc_acct);
336 $dbh->rollback if $oldAutoCommit;
341 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
348 Checks all fields to make sure this is a valid billing item. If there is an
349 error, returns the error, otherwise returns false. Called by the insert and
358 $self->ut_numbern('pkgnum')
359 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
360 || $self->ut_numbern('pkgpart')
361 || $self->ut_numbern('setup')
362 || $self->ut_numbern('bill')
363 || $self->ut_numbern('susp')
364 || $self->ut_numbern('cancel')
366 return $error if $error;
368 if ( $self->reg_code ) {
370 unless ( grep { $self->pkgpart == $_->pkgpart }
371 map { $_->reg_code_pkg }
372 qsearchs( 'reg_code', { 'code' => $self->reg_code,
373 'agentnum' => $self->cust_main->agentnum })
375 return "Unknown registration code";
378 } elsif ( $self->promo_code ) {
381 qsearchs('part_pkg', {
382 'pkgpart' => $self->pkgpart,
383 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
385 return 'Unknown promotional code' unless $promo_part_pkg;
389 unless ( $disable_agentcheck ) {
391 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
392 my $pkgpart_href = $agent->pkgpart_hashref;
393 return "agent ". $agent->agentnum.
394 " can't purchase pkgpart ". $self->pkgpart
395 unless $pkgpart_href->{ $self->pkgpart };
398 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
399 return $error if $error;
403 $self->otaker(getotaker) unless $self->otaker;
404 $self->otaker =~ /^([\w\.\-]{0,16})$/ or return "Illegal otaker";
407 if ( $self->dbdef_table->column('manual_flag') ) {
408 $self->manual_flag('') if $self->manual_flag eq ' ';
409 $self->manual_flag =~ /^([01]?)$/
410 or return "Illegal manual_flag ". $self->manual_flag;
411 $self->manual_flag($1);
417 =item cancel [ OPTION => VALUE ... ]
419 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
420 in this package, then cancels the package itself (sets the cancel field to
423 Available options are: I<quiet>
425 I<quiet> can be set true to supress email cancellation notices.
427 If there is an error, returns the error, otherwise returns false.
432 my( $self, %options ) = @_;
435 local $SIG{HUP} = 'IGNORE';
436 local $SIG{INT} = 'IGNORE';
437 local $SIG{QUIT} = 'IGNORE';
438 local $SIG{TERM} = 'IGNORE';
439 local $SIG{TSTP} = 'IGNORE';
440 local $SIG{PIPE} = 'IGNORE';
442 my $oldAutoCommit = $FS::UID::AutoCommit;
443 local $FS::UID::AutoCommit = 0;
446 if ($options{'reason'}) {
447 $error = $self->insert_reason( 'reason' => $options{'reason'} );
449 dbh->rollback if $oldAutoCommit;
450 return "Error inserting cust_pkg_reason: $error";
455 foreach my $cust_svc (
458 sort { $a->[1] <=> $b->[1] }
459 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
460 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
463 my $error = $cust_svc->cancel;
466 $dbh->rollback if $oldAutoCommit;
467 return "Error cancelling cust_svc: $error";
471 # Add a credit for remaining service
472 my $remaining_value = $self->calc_remain();
473 if ( $remaining_value > 0 ) {
474 my $error = $self->cust_main->credit(
476 'Credit for unused time on '. $self->part_pkg->pkg,
479 $dbh->rollback if $oldAutoCommit;
480 return "Error crediting customer \$$remaining_value for unused time on".
481 $self->part_pkg->pkg. ": $error";
485 unless ( $self->getfield('cancel') ) {
486 my %hash = $self->hash;
487 $hash{'cancel'} = time;
488 my $new = new FS::cust_pkg ( \%hash );
489 $error = $new->replace( $self, options => { $self->options } );
491 $dbh->rollback if $oldAutoCommit;
496 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
498 my $conf = new FS::Conf;
499 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
500 if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
501 my $conf = new FS::Conf;
502 my $error = send_email(
503 'from' => $conf->config('invoice_from'),
504 'to' => \@invoicing_list,
505 'subject' => $conf->config('cancelsubject'),
506 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
508 #should this do something on errors?
517 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
518 package, then suspends the package itself (sets the susp field to now).
520 If there is an error, returns the error, otherwise returns false.
525 my( $self, %options ) = @_;
528 local $SIG{HUP} = 'IGNORE';
529 local $SIG{INT} = 'IGNORE';
530 local $SIG{QUIT} = 'IGNORE';
531 local $SIG{TERM} = 'IGNORE';
532 local $SIG{TSTP} = 'IGNORE';
533 local $SIG{PIPE} = 'IGNORE';
535 my $oldAutoCommit = $FS::UID::AutoCommit;
536 local $FS::UID::AutoCommit = 0;
539 if ($options{'reason'}) {
540 $error = $self->insert_reason( 'reason' => $options{'reason'} );
542 dbh->rollback if $oldAutoCommit;
543 return "Error inserting cust_pkg_reason: $error";
547 foreach my $cust_svc (
548 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
550 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
552 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
553 $dbh->rollback if $oldAutoCommit;
554 return "Illegal svcdb value in part_svc!";
557 require "FS/$svcdb.pm";
559 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
561 $error = $svc->suspend;
563 $dbh->rollback if $oldAutoCommit;
570 unless ( $self->getfield('susp') ) {
571 my %hash = $self->hash;
572 $hash{'susp'} = time;
573 my $new = new FS::cust_pkg ( \%hash );
574 $error = $new->replace( $self, options => { $self->options } );
576 $dbh->rollback if $oldAutoCommit;
581 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
586 =item unsuspend [ OPTION => VALUE ... ]
588 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
589 package, then unsuspends the package itself (clears the susp field).
591 Available options are: I<adjust_next_bill>.
593 I<adjust_next_bill> can be set true to adjust the next bill date forward by
594 the amount of time the account was inactive. This was set true by default
595 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
596 explicitly requested. Price plans for which this makes sense (anniversary-date
597 based than prorate or subscription) could have an option to enable this
600 If there is an error, returns the error, otherwise returns false.
605 my( $self, %opt ) = @_;
608 local $SIG{HUP} = 'IGNORE';
609 local $SIG{INT} = 'IGNORE';
610 local $SIG{QUIT} = 'IGNORE';
611 local $SIG{TERM} = 'IGNORE';
612 local $SIG{TSTP} = 'IGNORE';
613 local $SIG{PIPE} = 'IGNORE';
615 my $oldAutoCommit = $FS::UID::AutoCommit;
616 local $FS::UID::AutoCommit = 0;
619 foreach my $cust_svc (
620 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
622 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
624 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
625 $dbh->rollback if $oldAutoCommit;
626 return "Illegal svcdb value in part_svc!";
629 require "FS/$svcdb.pm";
631 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
633 $error = $svc->unsuspend;
635 $dbh->rollback if $oldAutoCommit;
642 unless ( ! $self->getfield('susp') ) {
643 my %hash = $self->hash;
644 my $inactive = time - $hash{'susp'};
646 my $conf = new FS::Conf;
648 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
649 if ( $opt{'adjust_next_bill'}
650 || $conf->config('unsuspend-always_adjust_next_bill_date') )
651 && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
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;
669 Returns the last bill date, or if there is no last bill date, the setup date.
670 Useful for billing metered services.
676 if ( $self->dbdef_table->column('last_bill') ) {
677 return $self->setfield('last_bill', $_[0]) if @_;
678 return $self->getfield('last_bill') if $self->getfield('last_bill');
680 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
681 'edate' => $self->bill, } );
682 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
687 Returns the most recent FS::reason associated with the package.
693 my $cust_pkg_reason = qsearchs( {
694 'table' => 'cust_pkg_reason',
695 'hashref' => { 'pkgnum' => $self->pkgnum, },
696 'extra_sql'=> 'ORDER BY date DESC LIMIT 1',
698 qsearchs ( 'reason', { 'reasonnum' => $cust_pkg_reason->reasonnum } )
704 Returns the definition for this billing item, as an FS::part_pkg object (see
711 #exists( $self->{'_pkgpart'} )
713 ? $self->{'_pkgpart'}
714 : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
719 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
726 $self->part_pkg->calc_setup($self, @_);
731 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
738 $self->part_pkg->calc_recur($self, @_);
743 Calls the I<calc_remain> of the FS::part_pkg object associated with this
750 $self->part_pkg->calc_remain($self, @_);
755 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
762 $self->part_pkg->calc_cancel($self, @_);
767 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
773 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
776 =item cust_svc [ SVCPART ]
778 Returns the services for this package, as FS::cust_svc objects (see
779 L<FS::cust_svc>). If a svcpart is specified, return only the matching
788 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
789 'svcpart' => shift, } );
792 #if ( $self->{'_svcnum'} ) {
793 # values %{ $self->{'_svcnum'}->cache };
795 $self->_sort_cust_svc(
796 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
802 =item overlimit [ SVCPART ]
804 Returns the services for this package which have exceeded their
805 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
806 is specified, return only the matching services.
812 grep { $_->overlimit } $self->cust_svc;
815 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
817 Returns historical services for this package created before END TIMESTAMP and
818 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
819 (see L<FS::h_cust_svc>).
826 $self->_sort_cust_svc(
827 [ qsearch( 'h_cust_svc',
828 { 'pkgnum' => $self->pkgnum, },
829 FS::h_cust_svc->sql_h_search(@_),
836 my( $self, $arrayref ) = @_;
839 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
841 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
842 'svcpart' => $_->svcpart } );
844 $pkg_svc ? $pkg_svc->primary_svc : '',
845 $pkg_svc ? $pkg_svc->quantity : 0,
852 =item num_cust_svc [ SVCPART ]
854 Returns the number of provisioned services for this package. If a svcpart is
855 specified, counts only the matching services.
861 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
862 $sql .= ' AND svcpart = ?' if @_;
863 my $sth = dbh->prepare($sql) or die dbh->errstr;
864 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
865 $sth->fetchrow_arrayref->[0];
868 =item available_part_svc
870 Returns a list of FS::part_svc objects representing services included in this
871 package but not yet provisioned. Each FS::part_svc object also has an extra
872 field, I<num_avail>, which specifies the number of available services.
876 sub available_part_svc {
878 grep { $_->num_avail > 0 }
880 my $part_svc = $_->part_svc;
881 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
882 $_->quantity - $self->num_cust_svc($_->svcpart);
885 $self->part_pkg->pkg_svc;
890 Returns a list of FS::part_svc objects representing provisioned and available
891 services included in this package. Each FS::part_svc object also has the
892 following extra fields:
896 =item num_cust_svc (count)
898 =item num_avail (quantity - count)
900 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
903 label -> ($cust_svc->label)[1]
912 #XXX some sort of sort order besides numeric by svcpart...
913 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
915 my $part_svc = $pkg_svc->part_svc;
916 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
917 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
918 $part_svc->{'Hash'}{'num_avail'} =
919 max( 0, $pkg_svc->quantity - $num_cust_svc );
920 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
922 } $self->part_pkg->pkg_svc;
925 push @part_svc, map {
927 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
928 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
929 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
930 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
932 } $self->extra_part_svc;
940 Returns a list of FS::part_svc objects corresponding to services in this
941 package which are still provisioned but not (any longer) available in the
949 my $pkgnum = $self->pkgnum;
950 my $pkgpart = $self->pkgpart;
953 'table' => 'part_svc',
955 'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
956 WHERE pkg_svc.svcpart = part_svc.svcpart
957 AND pkg_svc.pkgpart = $pkgpart
960 AND 0 < ( SELECT count(*)
962 LEFT JOIN cust_pkg using ( pkgnum )
963 WHERE cust_svc.svcpart = part_svc.svcpart
971 Returns a short status string for this package, currently:
977 =item one-time charge
992 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
994 return 'cancelled' if $self->get('cancel');
995 return 'suspended' if $self->susp;
996 return 'not yet billed' unless $self->setup;
997 return 'one-time charge' if $freq =~ /^(0|$)/;
1003 Class method that returns the list of possible status strings for pacakges
1004 (see L<the status method|/status>). For example:
1006 @statuses = FS::cust_pkg->statuses();
1010 tie my %statuscolor, 'Tie::IxHash',
1011 'not yet billed' => '000000',
1012 'one-time charge' => '000000',
1013 'active' => '00CC00',
1014 'suspended' => 'FF9900',
1015 'cancelled' => 'FF0000',
1019 my $self = shift; #could be class...
1020 grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1021 # mayble split btw one-time vs. recur
1027 Returns a hex triplet color string for this package's status.
1033 $statuscolor{$self->status};
1038 Returns a list of lists, calling the label method for all services
1039 (see L<FS::cust_svc>) of this billing item.
1045 map { [ $_->label ] } $self->cust_svc;
1048 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1050 Like the labels method, but returns historical information on services that
1051 were active as of END_TIMESTAMP and (optionally) not cancelled before
1054 Returns a list of lists, calling the label method for all (historical) services
1055 (see L<FS::h_cust_svc>) of this billing item.
1061 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1064 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1066 Like h_labels, except returns a simple flat list, and shortens long
1067 (currently >5) lists of identical services to one line that lists the service
1068 label and the number of individual services rather than individual items.
1072 sub h_labels_short {
1076 #tie %labels, 'Tie::IxHash';
1077 push @{ $labels{$_->[0]} }, $_->[1]
1078 foreach $self->h_labels(@_);
1080 foreach my $label ( keys %labels ) {
1081 my @values = @{ $labels{$label} };
1082 my $num = scalar(@values);
1084 push @labels, "$label ($num)";
1086 push @labels, map { "$label: $_" } @values;
1096 Returns the parent customer object (see L<FS::cust_main>).
1102 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1105 =item seconds_since TIMESTAMP
1107 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1108 package have been online since TIMESTAMP, according to the session monitor.
1110 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1111 L<Time::Local> and L<Date::Parse> for conversion functions.
1116 my($self, $since) = @_;
1119 foreach my $cust_svc (
1120 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1122 $seconds += $cust_svc->seconds_since($since);
1129 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1131 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1132 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1135 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1136 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1142 sub seconds_since_sqlradacct {
1143 my($self, $start, $end) = @_;
1147 foreach my $cust_svc (
1149 my $part_svc = $_->part_svc;
1150 $part_svc->svcdb eq 'svc_acct'
1151 && scalar($part_svc->part_export('sqlradius'));
1154 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1161 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1163 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1164 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1168 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1169 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1174 sub attribute_since_sqlradacct {
1175 my($self, $start, $end, $attrib) = @_;
1179 foreach my $cust_svc (
1181 my $part_svc = $_->part_svc;
1182 $part_svc->svcdb eq 'svc_acct'
1183 && scalar($part_svc->part_export('sqlradius'));
1186 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1193 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1195 Transfers as many services as possible from this package to another package.
1197 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1198 object. The destination package must already exist.
1200 Services are moved only if the destination allows services with the correct
1201 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
1202 this option with caution! No provision is made for export differences
1203 between the old and new service definitions. Probably only should be used
1204 when your exports for all service definitions of a given svcdb are identical.
1205 (attempt a transfer without it first, to move all possible svcpart-matching
1208 Any services that can't be moved remain in the original package.
1210 Returns an error, if there is one; otherwise, returns the number of services
1211 that couldn't be moved.
1216 my ($self, $dest_pkgnum, %opt) = @_;
1222 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1223 $dest = $dest_pkgnum;
1224 $dest_pkgnum = $dest->pkgnum;
1226 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1229 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1231 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1232 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1235 foreach my $cust_svc ($dest->cust_svc) {
1236 $target{$cust_svc->svcpart}--;
1239 my %svcpart2svcparts = ();
1240 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1241 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1242 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1243 next if exists $svcpart2svcparts{$svcpart};
1244 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1245 $svcpart2svcparts{$svcpart} = [
1247 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
1249 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1250 'svcpart' => $_ } );
1252 $pkg_svc ? $pkg_svc->primary_svc : '',
1253 $pkg_svc ? $pkg_svc->quantity : 0,
1257 grep { $_ != $svcpart }
1259 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1261 warn "alternates for svcpart $svcpart: ".
1262 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1267 foreach my $cust_svc ($self->cust_svc) {
1268 if($target{$cust_svc->svcpart} > 0) {
1269 $target{$cust_svc->svcpart}--;
1270 my $new = new FS::cust_svc { $cust_svc->hash };
1271 $new->pkgnum($dest_pkgnum);
1272 my $error = $new->replace($cust_svc);
1273 return $error if $error;
1274 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1276 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1277 warn "alternates to consider: ".
1278 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1280 my @alternate = grep {
1281 warn "considering alternate svcpart $_: ".
1282 "$target{$_} available in new package\n"
1285 } @{$svcpart2svcparts{$cust_svc->svcpart}};
1287 warn "alternate(s) found\n" if $DEBUG;
1288 my $change_svcpart = $alternate[0];
1289 $target{$change_svcpart}--;
1290 my $new = new FS::cust_svc { $cust_svc->hash };
1291 $new->svcpart($change_svcpart);
1292 $new->pkgnum($dest_pkgnum);
1293 my $error = $new->replace($cust_svc);
1294 return $error if $error;
1307 This method is deprecated. See the I<depend_jobnum> option to the insert and
1308 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1315 local $SIG{HUP} = 'IGNORE';
1316 local $SIG{INT} = 'IGNORE';
1317 local $SIG{QUIT} = 'IGNORE';
1318 local $SIG{TERM} = 'IGNORE';
1319 local $SIG{TSTP} = 'IGNORE';
1320 local $SIG{PIPE} = 'IGNORE';
1322 my $oldAutoCommit = $FS::UID::AutoCommit;
1323 local $FS::UID::AutoCommit = 0;
1326 foreach my $cust_svc ( $self->cust_svc ) {
1327 #false laziness w/svc_Common::insert
1328 my $svc_x = $cust_svc->svc_x;
1329 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1330 my $error = $part_export->export_insert($svc_x);
1332 $dbh->rollback if $oldAutoCommit;
1338 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1345 =head1 CLASS METHODS
1351 Returns an SQL expression identifying recurring packages.
1355 sub recurring_sql { "
1356 '0' != ( select freq from part_pkg
1357 where cust_pkg.pkgpart = part_pkg.pkgpart )
1362 Returns an SQL expression identifying one-time packages.
1367 '0' = ( select freq from part_pkg
1368 where cust_pkg.pkgpart = part_pkg.pkgpart )
1373 Returns an SQL expression identifying active packages.
1378 ". $_[0]->recurring_sql(). "
1379 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1380 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1385 Returns an SQL expression identifying inactive packages (one-time packages
1386 that are otherwise unsuspended/uncancelled).
1390 sub inactive_sql { "
1391 ". $_[0]->onetime_sql(). "
1392 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1393 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1399 Returns an SQL expression identifying suspended packages.
1403 sub suspended_sql { susp_sql(@_); }
1405 #$_[0]->recurring_sql(). ' AND '.
1407 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1408 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
1415 Returns an SQL exprression identifying cancelled packages.
1419 sub cancelled_sql { cancel_sql(@_); }
1421 #$_[0]->recurring_sql(). ' AND '.
1422 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1429 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1431 CUSTNUM is a customer (see L<FS::cust_main>)
1433 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1434 L<FS::part_pkg>) to order for this customer. Duplicates are of course
1437 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1438 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
1439 new billing items. An error is returned if this is not possible (see
1440 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
1443 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1444 newly-created cust_pkg objects.
1449 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1451 my $conf = new FS::Conf;
1453 # Transactionize this whole mess
1454 local $SIG{HUP} = 'IGNORE';
1455 local $SIG{INT} = 'IGNORE';
1456 local $SIG{QUIT} = 'IGNORE';
1457 local $SIG{TERM} = 'IGNORE';
1458 local $SIG{TSTP} = 'IGNORE';
1459 local $SIG{PIPE} = 'IGNORE';
1461 my $oldAutoCommit = $FS::UID::AutoCommit;
1462 local $FS::UID::AutoCommit = 0;
1466 my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1467 return "Customer not found: $custnum" unless $cust_main;
1469 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1472 my $change = scalar(@old_cust_pkg) != 0;
1475 if ( scalar(@old_cust_pkg) == 1 ) {
1476 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1477 $hash{'setup'} = time;
1480 # Create the new packages.
1481 foreach my $pkgpart (@$pkgparts) {
1482 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1483 pkgpart => $pkgpart,
1486 $error = $cust_pkg->insert( 'change' => $change );
1488 $dbh->rollback if $oldAutoCommit;
1491 push @$return_cust_pkg, $cust_pkg;
1493 # $return_cust_pkg now contains refs to all of the newly
1496 # Transfer services and cancel old packages.
1497 foreach my $old_pkg (@old_cust_pkg) {
1499 foreach my $new_pkg (@$return_cust_pkg) {
1500 $error = $old_pkg->transfer($new_pkg);
1501 if ($error and $error == 0) {
1502 # $old_pkg->transfer failed.
1503 $dbh->rollback if $oldAutoCommit;
1508 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1509 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1510 foreach my $new_pkg (@$return_cust_pkg) {
1511 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1512 if ($error and $error == 0) {
1513 # $old_pkg->transfer failed.
1514 $dbh->rollback if $oldAutoCommit;
1521 # Transfers were successful, but we went through all of the
1522 # new packages and still had services left on the old package.
1523 # We can't cancel the package under the circumstances, so abort.
1524 $dbh->rollback if $oldAutoCommit;
1525 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1527 $error = $old_pkg->cancel( quiet=>1 );
1533 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1538 my ($self, %options) = @_;
1540 my $otaker = $FS::CurrentUser::CurrentUser->username;
1542 my $cust_pkg_reason =
1543 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
1544 'reasonnum' => $options{'reason'},
1545 'otaker' => $otaker,
1546 'date' => $options{'date'}
1550 return $cust_pkg_reason->insert;
1553 =item set_usage USAGE_VALUE_HASHREF
1555 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
1556 to which they should be set (see L<FS::svc_acct>). Currently seconds,
1557 upbytes, downbytes, and totalbytes are appropriate keys.
1559 All svc_accts which are part of this package have their values reset.
1564 my ($self, $valueref) = @_;
1566 foreach my $cust_svc ($self->cust_svc){
1567 my $svc_x = $cust_svc->svc_x;
1568 $svc_x->set_usage($valueref)
1569 if $svc_x->can("set_usage");
1577 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
1579 In sub order, the @pkgparts array (passed by reference) is clobbered.
1581 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
1582 method to pass dates to the recur_prog expression, it should do so.
1584 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1585 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1586 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1587 configuration values. Probably need a subroutine which decides what to do
1588 based on whether or not we've fetched the user yet, rather than a hash. See
1589 FS::UID and the TODO.
1591 Now that things are transactional should the check in the insert method be
1596 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1597 L<FS::pkg_svc>, schema.html from the base documentation