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 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
230 my $queue = new FS::queue {
231 'job' => 'FS::cust_main::queueable_print',
233 $error = $queue->insert(
234 'custnum' => $self->custnum,
235 'template' => 'welcome_letter',
239 warn "can't send welcome letter: $error";
244 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
251 This method now works but you probably shouldn't use it.
253 You don't want to delete billing items, because there would then be no record
254 the customer ever purchased the item. Instead, see the cancel method.
259 # return "Can't delete cust_pkg records!";
262 =item replace OLD_RECORD
264 Replaces the OLD_RECORD with this one in the database. If there is an error,
265 returns the error, otherwise returns false.
267 Currently, custnum, setup, bill, susp, expire, and cancel may be changed.
269 Changing pkgpart may have disasterous effects. See the order subroutine.
271 setup and bill are normally updated by calling the bill method of a customer
272 object (see L<FS::cust_main>).
274 suspend is normally updated by the suspend and unsuspend methods.
276 cancel is normally updated by the cancel method (and also the order subroutine
284 my( $new, $old, %options ) = @_;
286 # We absolutely have to have an old vs. new record to make this work.
287 if (!defined($old)) {
288 $old = qsearchs( 'cust_pkg', { 'pkgnum' => $new->pkgnum } );
290 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
291 return "Can't change otaker!" if $old->otaker ne $new->otaker;
294 #return "Can't change setup once it exists!"
295 # if $old->getfield('setup') &&
296 # $old->getfield('setup') != $new->getfield('setup');
298 #some logic for bill, susp, cancel?
300 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
302 local $SIG{HUP} = 'IGNORE';
303 local $SIG{INT} = 'IGNORE';
304 local $SIG{QUIT} = 'IGNORE';
305 local $SIG{TERM} = 'IGNORE';
306 local $SIG{TSTP} = 'IGNORE';
307 local $SIG{PIPE} = 'IGNORE';
309 my $oldAutoCommit = $FS::UID::AutoCommit;
310 local $FS::UID::AutoCommit = 0;
313 if ($options{'reason'} && $new->expire && $old->expire ne $new->expire) {
314 my $error = $new->insert_reason( 'reason' => $options{'reason'},
315 'date' => $new->expire,
318 dbh->rollback if $oldAutoCommit;
319 return "Error inserting cust_pkg_reason: $error";
323 #save off and freeze RADIUS attributes for any associated svc_acct records
325 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
327 #also check for specific exports?
328 # to avoid spurious modify export events
329 @svc_acct = map { $_->svc_x }
330 grep { $_->part_svc->svcdb eq 'svc_acct' }
333 $_->snapshot foreach @svc_acct;
337 my $error = $new->SUPER::replace($old,
338 $options{options} ? ${options{options}} : ()
341 $dbh->rollback if $oldAutoCommit;
345 #for prepaid packages,
346 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
347 foreach my $old_svc_acct ( @svc_acct ) {
348 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
349 my $s_error = $new_svc_acct->replace($old_svc_acct);
351 $dbh->rollback if $oldAutoCommit;
356 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
363 Checks all fields to make sure this is a valid billing item. If there is an
364 error, returns the error, otherwise returns false. Called by the insert and
373 $self->ut_numbern('pkgnum')
374 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
375 || $self->ut_numbern('pkgpart')
376 || $self->ut_numbern('setup')
377 || $self->ut_numbern('bill')
378 || $self->ut_numbern('susp')
379 || $self->ut_numbern('cancel')
381 return $error if $error;
383 if ( $self->reg_code ) {
385 unless ( grep { $self->pkgpart == $_->pkgpart }
386 map { $_->reg_code_pkg }
387 qsearchs( 'reg_code', { 'code' => $self->reg_code,
388 'agentnum' => $self->cust_main->agentnum })
390 return "Unknown registration code";
393 } elsif ( $self->promo_code ) {
396 qsearchs('part_pkg', {
397 'pkgpart' => $self->pkgpart,
398 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
400 return 'Unknown promotional code' unless $promo_part_pkg;
404 unless ( $disable_agentcheck ) {
406 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
407 my $pkgpart_href = $agent->pkgpart_hashref;
408 return "agent ". $agent->agentnum.
409 " can't purchase pkgpart ". $self->pkgpart
410 unless $pkgpart_href->{ $self->pkgpart };
413 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
414 return $error if $error;
418 $self->otaker(getotaker) unless $self->otaker;
419 $self->otaker =~ /^([\w\.\-]{0,16})$/ or return "Illegal otaker";
422 if ( $self->dbdef_table->column('manual_flag') ) {
423 $self->manual_flag('') if $self->manual_flag eq ' ';
424 $self->manual_flag =~ /^([01]?)$/
425 or return "Illegal manual_flag ". $self->manual_flag;
426 $self->manual_flag($1);
432 =item cancel [ OPTION => VALUE ... ]
434 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
435 in this package, then cancels the package itself (sets the cancel field to
438 Available options are: I<quiet>
440 I<quiet> can be set true to supress email cancellation notices.
442 If there is an error, returns the error, otherwise returns false.
447 my( $self, %options ) = @_;
450 local $SIG{HUP} = 'IGNORE';
451 local $SIG{INT} = 'IGNORE';
452 local $SIG{QUIT} = 'IGNORE';
453 local $SIG{TERM} = 'IGNORE';
454 local $SIG{TSTP} = 'IGNORE';
455 local $SIG{PIPE} = 'IGNORE';
457 my $oldAutoCommit = $FS::UID::AutoCommit;
458 local $FS::UID::AutoCommit = 0;
461 if ($options{'reason'}) {
462 $error = $self->insert_reason( 'reason' => $options{'reason'} );
464 dbh->rollback if $oldAutoCommit;
465 return "Error inserting cust_pkg_reason: $error";
470 foreach my $cust_svc (
473 sort { $a->[1] <=> $b->[1] }
474 map { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
475 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
478 my $error = $cust_svc->cancel;
481 $dbh->rollback if $oldAutoCommit;
482 return "Error cancelling cust_svc: $error";
486 # Add a credit for remaining service
487 my $remaining_value = $self->calc_remain();
488 if ( $remaining_value > 0 ) {
489 my $error = $self->cust_main->credit(
491 'Credit for unused time on '. $self->part_pkg->pkg,
494 $dbh->rollback if $oldAutoCommit;
495 return "Error crediting customer \$$remaining_value for unused time on".
496 $self->part_pkg->pkg. ": $error";
500 unless ( $self->getfield('cancel') ) {
501 my %hash = $self->hash;
502 $hash{'cancel'} = time;
503 my $new = new FS::cust_pkg ( \%hash );
504 $error = $new->replace( $self, options => { $self->options } );
506 $dbh->rollback if $oldAutoCommit;
511 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
513 my $conf = new FS::Conf;
514 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
515 if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
516 my $conf = new FS::Conf;
517 my $error = send_email(
518 'from' => $conf->config('invoice_from'),
519 'to' => \@invoicing_list,
520 'subject' => $conf->config('cancelsubject'),
521 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
523 #should this do something on errors?
532 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
533 package, then suspends the package itself (sets the susp field to now).
535 If there is an error, returns the error, otherwise returns false.
540 my( $self, %options ) = @_;
543 local $SIG{HUP} = 'IGNORE';
544 local $SIG{INT} = 'IGNORE';
545 local $SIG{QUIT} = 'IGNORE';
546 local $SIG{TERM} = 'IGNORE';
547 local $SIG{TSTP} = 'IGNORE';
548 local $SIG{PIPE} = 'IGNORE';
550 my $oldAutoCommit = $FS::UID::AutoCommit;
551 local $FS::UID::AutoCommit = 0;
554 if ($options{'reason'}) {
555 $error = $self->insert_reason( 'reason' => $options{'reason'} );
557 dbh->rollback if $oldAutoCommit;
558 return "Error inserting cust_pkg_reason: $error";
562 foreach my $cust_svc (
563 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
565 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
567 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
568 $dbh->rollback if $oldAutoCommit;
569 return "Illegal svcdb value in part_svc!";
572 require "FS/$svcdb.pm";
574 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
576 $error = $svc->suspend;
578 $dbh->rollback if $oldAutoCommit;
585 unless ( $self->getfield('susp') ) {
586 my %hash = $self->hash;
587 $hash{'susp'} = time;
588 my $new = new FS::cust_pkg ( \%hash );
589 $error = $new->replace( $self, options => { $self->options } );
591 $dbh->rollback if $oldAutoCommit;
596 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
601 =item unsuspend [ OPTION => VALUE ... ]
603 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
604 package, then unsuspends the package itself (clears the susp field).
606 Available options are: I<adjust_next_bill>.
608 I<adjust_next_bill> can be set true to adjust the next bill date forward by
609 the amount of time the account was inactive. This was set true by default
610 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
611 explicitly requested. Price plans for which this makes sense (anniversary-date
612 based than prorate or subscription) could have an option to enable this
615 If there is an error, returns the error, otherwise returns false.
620 my( $self, %opt ) = @_;
623 local $SIG{HUP} = 'IGNORE';
624 local $SIG{INT} = 'IGNORE';
625 local $SIG{QUIT} = 'IGNORE';
626 local $SIG{TERM} = 'IGNORE';
627 local $SIG{TSTP} = 'IGNORE';
628 local $SIG{PIPE} = 'IGNORE';
630 my $oldAutoCommit = $FS::UID::AutoCommit;
631 local $FS::UID::AutoCommit = 0;
634 foreach my $cust_svc (
635 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
637 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
639 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
640 $dbh->rollback if $oldAutoCommit;
641 return "Illegal svcdb value in part_svc!";
644 require "FS/$svcdb.pm";
646 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
648 $error = $svc->unsuspend;
650 $dbh->rollback if $oldAutoCommit;
657 unless ( ! $self->getfield('susp') ) {
658 my %hash = $self->hash;
659 my $inactive = time - $hash{'susp'};
661 my $conf = new FS::Conf;
663 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
664 if ( $opt{'adjust_next_bill'}
665 || $conf->config('unsuspend-always_adjust_next_bill_date') )
666 && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
669 my $new = new FS::cust_pkg ( \%hash );
670 $error = $new->replace( $self, options => { $self->options } );
672 $dbh->rollback if $oldAutoCommit;
677 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
684 Returns the last bill date, or if there is no last bill date, the setup date.
685 Useful for billing metered services.
691 if ( $self->dbdef_table->column('last_bill') ) {
692 return $self->setfield('last_bill', $_[0]) if @_;
693 return $self->getfield('last_bill') if $self->getfield('last_bill');
695 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
696 'edate' => $self->bill, } );
697 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
702 Returns the most recent FS::reason associated with the package.
708 my $cust_pkg_reason = qsearchs( {
709 'table' => 'cust_pkg_reason',
710 'hashref' => { 'pkgnum' => $self->pkgnum, },
711 'extra_sql'=> 'ORDER BY date DESC LIMIT 1',
713 qsearchs ( 'reason', { 'reasonnum' => $cust_pkg_reason->reasonnum } )
719 Returns the definition for this billing item, as an FS::part_pkg object (see
726 #exists( $self->{'_pkgpart'} )
728 ? $self->{'_pkgpart'}
729 : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
734 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
741 $self->part_pkg->calc_setup($self, @_);
746 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
753 $self->part_pkg->calc_recur($self, @_);
758 Calls the I<calc_remain> of the FS::part_pkg object associated with this
765 $self->part_pkg->calc_remain($self, @_);
770 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
777 $self->part_pkg->calc_cancel($self, @_);
782 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
788 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
791 =item cust_svc [ SVCPART ]
793 Returns the services for this package, as FS::cust_svc objects (see
794 L<FS::cust_svc>). If a svcpart is specified, return only the matching
803 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
804 'svcpart' => shift, } );
807 #if ( $self->{'_svcnum'} ) {
808 # values %{ $self->{'_svcnum'}->cache };
810 $self->_sort_cust_svc(
811 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
817 =item overlimit [ SVCPART ]
819 Returns the services for this package which have exceeded their
820 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
821 is specified, return only the matching services.
827 grep { $_->overlimit } $self->cust_svc;
830 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
832 Returns historical services for this package created before END TIMESTAMP and
833 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
834 (see L<FS::h_cust_svc>).
841 $self->_sort_cust_svc(
842 [ qsearch( 'h_cust_svc',
843 { 'pkgnum' => $self->pkgnum, },
844 FS::h_cust_svc->sql_h_search(@_),
851 my( $self, $arrayref ) = @_;
854 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
856 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
857 'svcpart' => $_->svcpart } );
859 $pkg_svc ? $pkg_svc->primary_svc : '',
860 $pkg_svc ? $pkg_svc->quantity : 0,
867 =item num_cust_svc [ SVCPART ]
869 Returns the number of provisioned services for this package. If a svcpart is
870 specified, counts only the matching services.
876 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
877 $sql .= ' AND svcpart = ?' if @_;
878 my $sth = dbh->prepare($sql) or die dbh->errstr;
879 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
880 $sth->fetchrow_arrayref->[0];
883 =item available_part_svc
885 Returns a list of FS::part_svc objects representing services included in this
886 package but not yet provisioned. Each FS::part_svc object also has an extra
887 field, I<num_avail>, which specifies the number of available services.
891 sub available_part_svc {
893 grep { $_->num_avail > 0 }
895 my $part_svc = $_->part_svc;
896 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
897 $_->quantity - $self->num_cust_svc($_->svcpart);
900 $self->part_pkg->pkg_svc;
905 Returns a list of FS::part_svc objects representing provisioned and available
906 services included in this package. Each FS::part_svc object also has the
907 following extra fields:
911 =item num_cust_svc (count)
913 =item num_avail (quantity - count)
915 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
918 label -> ($cust_svc->label)[1]
927 #XXX some sort of sort order besides numeric by svcpart...
928 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
930 my $part_svc = $pkg_svc->part_svc;
931 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
932 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
933 $part_svc->{'Hash'}{'num_avail'} =
934 max( 0, $pkg_svc->quantity - $num_cust_svc );
935 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
937 } $self->part_pkg->pkg_svc;
940 push @part_svc, map {
942 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
943 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
944 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
945 $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
947 } $self->extra_part_svc;
955 Returns a list of FS::part_svc objects corresponding to services in this
956 package which are still provisioned but not (any longer) available in the
964 my $pkgnum = $self->pkgnum;
965 my $pkgpart = $self->pkgpart;
968 'table' => 'part_svc',
970 'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
971 WHERE pkg_svc.svcpart = part_svc.svcpart
972 AND pkg_svc.pkgpart = $pkgpart
975 AND 0 < ( SELECT count(*)
977 LEFT JOIN cust_pkg using ( pkgnum )
978 WHERE cust_svc.svcpart = part_svc.svcpart
986 Returns a short status string for this package, currently:
992 =item one-time charge
1007 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1009 return 'cancelled' if $self->get('cancel');
1010 return 'suspended' if $self->susp;
1011 return 'not yet billed' unless $self->setup;
1012 return 'one-time charge' if $freq =~ /^(0|$)/;
1018 Class method that returns the list of possible status strings for pacakges
1019 (see L<the status method|/status>). For example:
1021 @statuses = FS::cust_pkg->statuses();
1025 tie my %statuscolor, 'Tie::IxHash',
1026 'not yet billed' => '000000',
1027 'one-time charge' => '000000',
1028 'active' => '00CC00',
1029 'suspended' => 'FF9900',
1030 'cancelled' => 'FF0000',
1034 my $self = shift; #could be class...
1035 grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1036 # mayble split btw one-time vs. recur
1042 Returns a hex triplet color string for this package's status.
1048 $statuscolor{$self->status};
1053 Returns a list of lists, calling the label method for all services
1054 (see L<FS::cust_svc>) of this billing item.
1060 map { [ $_->label ] } $self->cust_svc;
1063 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1065 Like the labels method, but returns historical information on services that
1066 were active as of END_TIMESTAMP and (optionally) not cancelled before
1069 Returns a list of lists, calling the label method for all (historical) services
1070 (see L<FS::h_cust_svc>) of this billing item.
1076 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1079 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1081 Like h_labels, except returns a simple flat list, and shortens long
1082 (currently >5) lists of identical services to one line that lists the service
1083 label and the number of individual services rather than individual items.
1087 sub h_labels_short {
1091 #tie %labels, 'Tie::IxHash';
1092 push @{ $labels{$_->[0]} }, $_->[1]
1093 foreach $self->h_labels(@_);
1095 foreach my $label ( keys %labels ) {
1096 my @values = @{ $labels{$label} };
1097 my $num = scalar(@values);
1099 push @labels, "$label ($num)";
1101 push @labels, map { "$label: $_" } @values;
1111 Returns the parent customer object (see L<FS::cust_main>).
1117 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1120 =item seconds_since TIMESTAMP
1122 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1123 package have been online since TIMESTAMP, according to the session monitor.
1125 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1126 L<Time::Local> and L<Date::Parse> for conversion functions.
1131 my($self, $since) = @_;
1134 foreach my $cust_svc (
1135 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1137 $seconds += $cust_svc->seconds_since($since);
1144 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1146 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1147 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1150 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1151 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1157 sub seconds_since_sqlradacct {
1158 my($self, $start, $end) = @_;
1162 foreach my $cust_svc (
1164 my $part_svc = $_->part_svc;
1165 $part_svc->svcdb eq 'svc_acct'
1166 && scalar($part_svc->part_export('sqlradius'));
1169 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1176 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1178 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1179 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1183 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1184 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1189 sub attribute_since_sqlradacct {
1190 my($self, $start, $end, $attrib) = @_;
1194 foreach my $cust_svc (
1196 my $part_svc = $_->part_svc;
1197 $part_svc->svcdb eq 'svc_acct'
1198 && scalar($part_svc->part_export('sqlradius'));
1201 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1208 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1210 Transfers as many services as possible from this package to another package.
1212 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1213 object. The destination package must already exist.
1215 Services are moved only if the destination allows services with the correct
1216 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
1217 this option with caution! No provision is made for export differences
1218 between the old and new service definitions. Probably only should be used
1219 when your exports for all service definitions of a given svcdb are identical.
1220 (attempt a transfer without it first, to move all possible svcpart-matching
1223 Any services that can't be moved remain in the original package.
1225 Returns an error, if there is one; otherwise, returns the number of services
1226 that couldn't be moved.
1231 my ($self, $dest_pkgnum, %opt) = @_;
1237 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1238 $dest = $dest_pkgnum;
1239 $dest_pkgnum = $dest->pkgnum;
1241 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1244 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1246 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1247 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1250 foreach my $cust_svc ($dest->cust_svc) {
1251 $target{$cust_svc->svcpart}--;
1254 my %svcpart2svcparts = ();
1255 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1256 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1257 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1258 next if exists $svcpart2svcparts{$svcpart};
1259 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1260 $svcpart2svcparts{$svcpart} = [
1262 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
1264 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1265 'svcpart' => $_ } );
1267 $pkg_svc ? $pkg_svc->primary_svc : '',
1268 $pkg_svc ? $pkg_svc->quantity : 0,
1272 grep { $_ != $svcpart }
1274 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1276 warn "alternates for svcpart $svcpart: ".
1277 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1282 foreach my $cust_svc ($self->cust_svc) {
1283 if($target{$cust_svc->svcpart} > 0) {
1284 $target{$cust_svc->svcpart}--;
1285 my $new = new FS::cust_svc { $cust_svc->hash };
1286 $new->pkgnum($dest_pkgnum);
1287 my $error = $new->replace($cust_svc);
1288 return $error if $error;
1289 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1291 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1292 warn "alternates to consider: ".
1293 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1295 my @alternate = grep {
1296 warn "considering alternate svcpart $_: ".
1297 "$target{$_} available in new package\n"
1300 } @{$svcpart2svcparts{$cust_svc->svcpart}};
1302 warn "alternate(s) found\n" if $DEBUG;
1303 my $change_svcpart = $alternate[0];
1304 $target{$change_svcpart}--;
1305 my $new = new FS::cust_svc { $cust_svc->hash };
1306 $new->svcpart($change_svcpart);
1307 $new->pkgnum($dest_pkgnum);
1308 my $error = $new->replace($cust_svc);
1309 return $error if $error;
1322 This method is deprecated. See the I<depend_jobnum> option to the insert and
1323 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1330 local $SIG{HUP} = 'IGNORE';
1331 local $SIG{INT} = 'IGNORE';
1332 local $SIG{QUIT} = 'IGNORE';
1333 local $SIG{TERM} = 'IGNORE';
1334 local $SIG{TSTP} = 'IGNORE';
1335 local $SIG{PIPE} = 'IGNORE';
1337 my $oldAutoCommit = $FS::UID::AutoCommit;
1338 local $FS::UID::AutoCommit = 0;
1341 foreach my $cust_svc ( $self->cust_svc ) {
1342 #false laziness w/svc_Common::insert
1343 my $svc_x = $cust_svc->svc_x;
1344 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1345 my $error = $part_export->export_insert($svc_x);
1347 $dbh->rollback if $oldAutoCommit;
1353 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1360 =head1 CLASS METHODS
1366 Returns an SQL expression identifying recurring packages.
1370 sub recurring_sql { "
1371 '0' != ( select freq from part_pkg
1372 where cust_pkg.pkgpart = part_pkg.pkgpart )
1377 Returns an SQL expression identifying one-time packages.
1382 '0' = ( select freq from part_pkg
1383 where cust_pkg.pkgpart = part_pkg.pkgpart )
1388 Returns an SQL expression identifying active packages.
1393 ". $_[0]->recurring_sql(). "
1394 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1395 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1400 Returns an SQL expression identifying inactive packages (one-time packages
1401 that are otherwise unsuspended/uncancelled).
1405 sub inactive_sql { "
1406 ". $_[0]->onetime_sql(). "
1407 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1408 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1414 Returns an SQL expression identifying suspended packages.
1418 sub suspended_sql { susp_sql(@_); }
1420 #$_[0]->recurring_sql(). ' AND '.
1422 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1423 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
1430 Returns an SQL exprression identifying cancelled packages.
1434 sub cancelled_sql { cancel_sql(@_); }
1436 #$_[0]->recurring_sql(). ' AND '.
1437 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1444 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1446 CUSTNUM is a customer (see L<FS::cust_main>)
1448 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1449 L<FS::part_pkg>) to order for this customer. Duplicates are of course
1452 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1453 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
1454 new billing items. An error is returned if this is not possible (see
1455 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
1458 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1459 newly-created cust_pkg objects.
1464 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1466 my $conf = new FS::Conf;
1468 # Transactionize this whole mess
1469 local $SIG{HUP} = 'IGNORE';
1470 local $SIG{INT} = 'IGNORE';
1471 local $SIG{QUIT} = 'IGNORE';
1472 local $SIG{TERM} = 'IGNORE';
1473 local $SIG{TSTP} = 'IGNORE';
1474 local $SIG{PIPE} = 'IGNORE';
1476 my $oldAutoCommit = $FS::UID::AutoCommit;
1477 local $FS::UID::AutoCommit = 0;
1481 my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1482 return "Customer not found: $custnum" unless $cust_main;
1484 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1487 my $change = scalar(@old_cust_pkg) != 0;
1490 if ( scalar(@old_cust_pkg) == 1 ) {
1491 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1492 $hash{'setup'} = time;
1495 # Create the new packages.
1496 foreach my $pkgpart (@$pkgparts) {
1497 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1498 pkgpart => $pkgpart,
1501 $error = $cust_pkg->insert( 'change' => $change );
1503 $dbh->rollback if $oldAutoCommit;
1506 push @$return_cust_pkg, $cust_pkg;
1508 # $return_cust_pkg now contains refs to all of the newly
1511 # Transfer services and cancel old packages.
1512 foreach my $old_pkg (@old_cust_pkg) {
1514 foreach my $new_pkg (@$return_cust_pkg) {
1515 $error = $old_pkg->transfer($new_pkg);
1516 if ($error and $error == 0) {
1517 # $old_pkg->transfer failed.
1518 $dbh->rollback if $oldAutoCommit;
1523 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1524 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1525 foreach my $new_pkg (@$return_cust_pkg) {
1526 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1527 if ($error and $error == 0) {
1528 # $old_pkg->transfer failed.
1529 $dbh->rollback if $oldAutoCommit;
1536 # Transfers were successful, but we went through all of the
1537 # new packages and still had services left on the old package.
1538 # We can't cancel the package under the circumstances, so abort.
1539 $dbh->rollback if $oldAutoCommit;
1540 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1542 $error = $old_pkg->cancel( quiet=>1 );
1548 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1553 my ($self, %options) = @_;
1555 my $otaker = $FS::CurrentUser::CurrentUser->username;
1557 my $cust_pkg_reason =
1558 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
1559 'reasonnum' => $options{'reason'},
1560 'otaker' => $otaker,
1561 'date' => $options{'date'}
1565 return $cust_pkg_reason->insert;
1568 =item set_usage USAGE_VALUE_HASHREF
1570 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
1571 to which they should be set (see L<FS::svc_acct>). Currently seconds,
1572 upbytes, downbytes, and totalbytes are appropriate keys.
1574 All svc_accts which are part of this package have their values reset.
1579 my ($self, $valueref) = @_;
1581 foreach my $cust_svc ($self->cust_svc){
1582 my $svc_x = $cust_svc->svc_x;
1583 $svc_x->set_usage($valueref)
1584 if $svc_x->can("set_usage");
1592 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
1594 In sub order, the @pkgparts array (passed by reference) is clobbered.
1596 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
1597 method to pass dates to the recur_prog expression, it should do so.
1599 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1600 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1601 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1602 configuration values. Probably need a subroutine which decides what to do
1603 based on whether or not we've fetched the user yet, rather than a hash. See
1604 FS::UID and the TODO.
1606 Now that things are transactional should the check in the insert method be
1611 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1612 L<FS::pkg_svc>, schema.html from the base documentation