2 use base qw( FS::cust_pkg::Search FS::cust_pkg::API
3 FS::otaker_Mixin FS::cust_main_Mixin FS::Sales_Mixin
4 FS::contact_Mixin FS::location_Mixin
5 FS::m2m_Common FS::option_Common
10 use Scalar::Util qw( blessed );
11 use List::Util qw(min max);
13 use Time::Local qw( timelocal timelocal_nocheck );
15 use FS::UID qw( dbh driver_name );
16 use FS::Misc qw( send_email );
17 use FS::Record qw( qsearch qsearchs fields );
23 use FS::cust_location;
25 use FS::cust_bill_pkg;
26 use FS::cust_pkg_detail;
27 use FS::cust_pkg_usage;
28 use FS::cdr_cust_pkg_usage;
33 use FS::cust_pkg_reason;
35 use FS::cust_pkg_usageprice;
36 use FS::cust_pkg_discount;
42 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
44 # because they load configuration by setting FS::UID::callback (see TODO)
50 # for sending cancel emails in sub cancel
53 our ($disable_agentcheck, $DEBUG, $me, $import) = (0, 0, '[FS::cust_pkg]', 0);
55 our $upgrade = 0; #go away after setup+start dates cleaned up for old customers
59 my ( $hashref, $cache ) = @_;
60 #if ( $hashref->{'pkgpart'} ) {
61 if ( $hashref->{'pkg'} ) {
62 # #@{ $self->{'_pkgnum'} } = ();
63 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
64 # $self->{'_pkgpart'} = $subcache;
65 # #push @{ $self->{'_pkgnum'} },
66 # FS::part_pkg->new_or_cached($hashref, $subcache);
67 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
69 if ( exists $hashref->{'svcnum'} ) {
70 #@{ $self->{'_pkgnum'} } = ();
71 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
72 $self->{'_svcnum'} = $subcache;
73 #push @{ $self->{'_pkgnum'} },
74 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
80 FS::cust_pkg - Object methods for cust_pkg objects
86 $record = new FS::cust_pkg \%hash;
87 $record = new FS::cust_pkg { 'column' => 'value' };
89 $error = $record->insert;
91 $error = $new_record->replace($old_record);
93 $error = $record->delete;
95 $error = $record->check;
97 $error = $record->cancel;
99 $error = $record->suspend;
101 $error = $record->unsuspend;
103 $part_pkg = $record->part_pkg;
105 @labels = $record->labels;
107 $seconds = $record->seconds_since($timestamp);
109 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
110 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
114 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
115 inherits from FS::Record. The following fields are currently supported:
121 Primary key (assigned automatically for new billing items)
125 Customer (see L<FS::cust_main>)
129 Billing item definition (see L<FS::part_pkg>)
133 Optional link to package location (see L<FS::location>)
137 date package was ordered (also remains same on changes)
149 date (next bill date)
177 order taker (see L<FS::access_user>)
181 If this field is set to 1, disables the automatic
182 unsuspension of this package when using the B<unsuspendauto> config option.
186 If not set, defaults to 1
190 Date of change from previous package
200 =item change_locationnum
208 The pkgnum of the package that this package is supplemental to, if any.
212 The package link (L<FS::part_pkg_link>) that defines this supplemental
213 package, if it is one.
215 =item change_to_pkgnum
217 The pkgnum of the package this one will be "changed to" in the future
218 (on its expiration date).
222 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
223 are specified as UNIX timestamps; see L<perlfunc/"time">. Also see
224 L<Time::Local> and L<Date::Parse> for conversion functions.
232 Create a new billing item. To add the item to the database, see L<"insert">.
236 sub table { 'cust_pkg'; }
237 sub cust_linked { $_[0]->cust_main_custnum || $_[0]->custnum }
238 sub cust_unlinked_msg {
240 "WARNING: can't find cust_main.custnum ". $self->custnum.
241 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
244 =item set_initial_timers
246 If required by the package definition, sets any automatic expire, adjourn,
247 or contract_end timers to some number of months after the start date
248 (or setup date, if the package has already been setup). If the package has
249 a delayed setup fee after a period of "free days", will also set the
250 start date to the end of that period.
254 sub set_initial_timers {
256 my $part_pkg = $self->part_pkg;
257 foreach my $action ( qw(expire adjourn contract_end) ) {
258 my $months = $part_pkg->option("${action}_months",1);
259 if($months and !$self->get($action)) {
260 my $start = $self->start_date || $self->setup || time;
261 $self->set($action, $part_pkg->add_freq($start, $months) );
265 # if this package has "free days" and delayed setup fee, then
266 # set start date that many days in the future.
267 # (this should have been set in the UI, but enforce it here)
268 if ( $part_pkg->option('free_days',1)
269 && $part_pkg->option('delay_setup',1)
272 $self->start_date( $part_pkg->default_start_date );
277 =item insert [ OPTION => VALUE ... ]
279 Adds this billing item to the database ("Orders" the item). If there is an
280 error, returns the error, otherwise returns false.
282 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
283 will be used to look up the package definition and agent restrictions will be
286 If the additional field I<refnum> is defined, an FS::pkg_referral record will
287 be created and inserted. Multiple FS::pkg_referral records can be created by
288 setting I<refnum> to an array reference of refnums or a hash reference with
289 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
290 record will be created corresponding to cust_main.refnum.
292 If the additional field I<cust_pkg_usageprice> is defined, it will be treated
293 as an arrayref of FS::cust_pkg_usageprice objects, which will be inserted.
294 (Note that this field cannot be set with a usual ->cust_pkg_usageprice method.
295 It can be set as part of the hash when creating the object, or with the B<set>
298 The following options are available:
304 If set true, supresses actions that should only be taken for new package
305 orders. (Currently this includes: intro periods when delay_setup is on,
306 auto-adding a 1st start date, auto-adding expiration/adjourn/contract_end dates)
310 cust_pkg_option records will be created
314 a ticket will be added to this customer with this subject
318 an optional queue name for ticket additions
322 Don't check the legality of the package definition. This should be used
323 when performing a package change that doesn't change the pkgpart (i.e.
331 my( $self, %options ) = @_;
334 $error = $self->check_pkgpart unless $options{'allow_pkgpart'};
335 return $error if $error;
337 my $part_pkg = $self->part_pkg;
339 if ( ! $import && ! $options{'change'} ) {
341 # set order date to now
342 $self->order_date(time) unless ($import && $self->order_date);
344 # if the package def says to start only on the first of the month:
345 if ( $part_pkg->option('start_1st', 1) && !$self->start_date ) {
346 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
347 $mon += 1 unless $mday == 1;
348 until ( $mon < 12 ) { $mon -= 12; $year++; }
349 $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
352 if ($self->susp eq 'now' or $part_pkg->start_on_hold) {
353 # if the package was ordered on hold:
355 # - don't set the start date (it will be started manually)
356 $self->set('susp', $self->order_date);
357 $self->set('start_date', '');
359 # set expire/adjourn/contract_end timers, and free days, if appropriate
360 $self->set_initial_timers;
362 } # else this is a package change, and shouldn't have "new package" behavior
364 my $oldAutoCommit = $FS::UID::AutoCommit;
365 local $FS::UID::AutoCommit = 0;
368 $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
370 $dbh->rollback if $oldAutoCommit;
374 $self->refnum($self->cust_main->refnum) unless $self->refnum;
375 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
376 $self->process_m2m( 'link_table' => 'pkg_referral',
377 'target_table' => 'part_referral',
378 'params' => $self->refnum,
381 if ( $self->hashref->{cust_pkg_usageprice} ) {
382 for my $cust_pkg_usageprice ( @{ $self->hashref->{cust_pkg_usageprice} } ) {
383 $cust_pkg_usageprice->pkgnum( $self->pkgnum );
384 my $error = $cust_pkg_usageprice->insert;
386 $dbh->rollback if $oldAutoCommit;
392 if ( $self->discountnum ) {
393 my $error = $self->insert_discount();
395 $dbh->rollback if $oldAutoCommit;
400 my $conf = new FS::Conf;
402 if ( ! $import && $conf->config('ticket_system') && $options{ticket_subject} ) {
404 #this init stuff is still inefficient, but at least its limited to
405 # the small number (any?) folks using ticket emailing on pkg order
408 # use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
415 use FS::TicketSystem;
416 FS::TicketSystem->init();
418 my $q = new RT::Queue($RT::SystemUser);
419 $q->Load($options{ticket_queue}) if $options{ticket_queue};
420 my $t = new RT::Ticket($RT::SystemUser);
421 my $mime = new MIME::Entity;
422 $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
423 $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
424 Subject => $options{ticket_subject},
427 $t->AddLink( Type => 'MemberOf',
428 Target => 'freeside://freeside/cust_main/'. $self->custnum,
432 if (! $import && $conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
433 my $queue = new FS::queue {
434 'job' => 'FS::cust_main::queueable_print',
436 $error = $queue->insert(
437 'custnum' => $self->custnum,
438 'template' => 'welcome_letter',
442 warn "can't send welcome letter: $error";
447 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
454 This method now works but you probably shouldn't use it.
456 You don't want to delete packages, because there would then be no record
457 the customer ever purchased the package. Instead, see the cancel method and
458 hide cancelled packages.
465 my $oldAutoCommit = $FS::UID::AutoCommit;
466 local $FS::UID::AutoCommit = 0;
469 foreach my $cust_pkg_discount ($self->cust_pkg_discount) {
470 my $error = $cust_pkg_discount->delete;
472 $dbh->rollback if $oldAutoCommit;
476 #cust_bill_pkg_discount?
478 foreach my $cust_pkg_detail ($self->cust_pkg_detail) {
479 my $error = $cust_pkg_detail->delete;
481 $dbh->rollback if $oldAutoCommit;
486 foreach my $cust_pkg_reason (
488 'table' => 'cust_pkg_reason',
489 'hashref' => { 'pkgnum' => $self->pkgnum },
493 my $error = $cust_pkg_reason->delete;
495 $dbh->rollback if $oldAutoCommit;
502 my $error = $self->SUPER::delete(@_);
504 $dbh->rollback if $oldAutoCommit;
508 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
514 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
516 Replaces the OLD_RECORD with this one in the database. If there is an error,
517 returns the error, otherwise returns false.
519 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
521 Changing pkgpart may have disasterous effects. See the order subroutine.
523 setup and bill are normally updated by calling the bill method of a customer
524 object (see L<FS::cust_main>).
526 suspend is normally updated by the suspend and unsuspend methods.
528 cancel is normally updated by the cancel method (and also the order subroutine
531 Available options are:
537 can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason. The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
541 the access_user (see L<FS::access_user>) providing the reason
545 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
554 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
559 ( ref($_[0]) eq 'HASH' )
563 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
564 #return "Can't change otaker!" if $old->otaker ne $new->otaker;
567 #return "Can't change setup once it exists!"
568 # if $old->getfield('setup') &&
569 # $old->getfield('setup') != $new->getfield('setup');
571 #some logic for bill, susp, cancel?
573 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
575 my $oldAutoCommit = $FS::UID::AutoCommit;
576 local $FS::UID::AutoCommit = 0;
579 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
580 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
581 my $error = $new->insert_reason(
582 'reason' => $options->{'reason'},
583 'date' => $new->$method,
585 'reason_otaker' => $options->{'reason_otaker'},
588 dbh->rollback if $oldAutoCommit;
589 return "Error inserting cust_pkg_reason: $error";
594 #save off and freeze RADIUS attributes for any associated svc_acct records
596 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
598 #also check for specific exports?
599 # to avoid spurious modify export events
600 @svc_acct = map { $_->svc_x }
601 grep { $_->part_svc->svcdb eq 'svc_acct' }
604 $_->snapshot foreach @svc_acct;
608 my $error = $new->export_pkg_change($old)
609 || $new->SUPER::replace( $old,
611 ? $options->{options}
615 $dbh->rollback if $oldAutoCommit;
619 #for prepaid packages,
620 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
621 foreach my $old_svc_acct ( @svc_acct ) {
622 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
624 $new_svc_acct->replace( $old_svc_acct,
625 'depend_jobnum' => $options->{depend_jobnum},
628 $dbh->rollback if $oldAutoCommit;
633 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
640 Checks all fields to make sure this is a valid billing item. If there is an
641 error, returns the error, otherwise returns false. Called by the insert and
649 if ( !$self->locationnum or $self->locationnum == -1 ) {
650 $self->set('locationnum', $self->cust_main->ship_locationnum);
654 $self->ut_numbern('pkgnum')
655 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
656 || $self->ut_numbern('pkgpart')
657 || $self->ut_foreign_keyn('contactnum', 'contact', 'contactnum' )
658 || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
659 || $self->ut_foreign_keyn('salesnum', 'sales', 'salesnum')
660 || $self->ut_numbern('quantity')
661 || $self->ut_numbern('start_date')
662 || $self->ut_numbern('setup')
663 || $self->ut_numbern('bill')
664 || $self->ut_numbern('susp')
665 || $self->ut_numbern('cancel')
666 || $self->ut_numbern('adjourn')
667 || $self->ut_numbern('resume')
668 || $self->ut_numbern('expire')
669 || $self->ut_numbern('dundate')
670 || $self->ut_enum('no_auto', [ '', 'Y' ])
671 || $self->ut_enum('waive_setup', [ '', 'Y' ])
672 || $self->ut_textn('agent_pkgid')
673 || $self->ut_enum('recur_show_zero', [ '', 'Y', 'N', ])
674 || $self->ut_enum('setup_show_zero', [ '', 'Y', 'N', ])
675 || $self->ut_foreign_keyn('main_pkgnum', 'cust_pkg', 'pkgnum')
676 || $self->ut_foreign_keyn('pkglinknum', 'part_pkg_link', 'pkglinknum')
677 || $self->ut_foreign_keyn('change_to_pkgnum', 'cust_pkg', 'pkgnum')
679 return $error if $error;
681 return "A package with both start date (future start) and setup date (already started) will never bill"
682 if $self->start_date && $self->setup && ! $upgrade;
684 return "A future unsuspend date can only be set for a package with a suspend date"
685 if $self->resume and !$self->susp and !$self->adjourn;
687 $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
689 if ( $self->dbdef_table->column('manual_flag') ) {
690 $self->manual_flag('') if $self->manual_flag eq ' ';
691 $self->manual_flag =~ /^([01]?)$/
692 or return "Illegal manual_flag ". $self->manual_flag;
693 $self->manual_flag($1);
701 Check the pkgpart to make sure it's allowed with the reg_code and/or
702 promo_code of the package (if present) and with the customer's agent.
703 Called from C<insert>, unless we are doing a package change that doesn't
711 # my $error = $self->ut_numbern('pkgpart'); # already done
714 if ( $self->reg_code ) {
716 unless ( grep { $self->pkgpart == $_->pkgpart }
717 map { $_->reg_code_pkg }
718 qsearchs( 'reg_code', { 'code' => $self->reg_code,
719 'agentnum' => $self->cust_main->agentnum })
721 return "Unknown registration code";
724 } elsif ( $self->promo_code ) {
727 qsearchs('part_pkg', {
728 'pkgpart' => $self->pkgpart,
729 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
731 return 'Unknown promotional code' unless $promo_part_pkg;
735 unless ( $disable_agentcheck ) {
737 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
738 return "agent ". $agent->agentnum. ':'. $agent->agent.
739 " can't purchase pkgpart ". $self->pkgpart
740 unless $agent->pkgpart_hashref->{ $self->pkgpart }
741 || $agent->agentnum == $self->part_pkg->agentnum;
744 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
745 return $error if $error;
753 =item cancel [ OPTION => VALUE ... ]
755 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
756 in this package, then cancels the package itself (sets the cancel field to
759 Available options are:
763 =item quiet - can be set true to supress email cancellation notices.
765 =item time - can be set to cancel the package based on a specific future or
766 historical date. Using time ensures that the remaining amount is calculated
767 correctly. Note however that this is an immediate cancel and just changes
768 the date. You are PROBABLY looking to expire the account instead of using
771 =item reason - can be set to a cancellation reason (see L<FS:reason>),
772 either a reasonnum of an existing reason, or passing a hashref will create
773 a new reason. The hashref should have the following keys: typenum - Reason
774 type (see L<FS::reason_type>, reason - Text of the new reason.
776 =item date - can be set to a unix style timestamp to specify when to
779 =item nobill - can be set true to skip billing if it might otherwise be done.
781 =item unused_credit - can be set to 1 to credit the remaining time, or 0 to
782 not credit it. This must be set (by change()) when changing the package
783 to a different pkgpart or location, and probably shouldn't be in any other
784 case. If it's not set, the 'unused_credit_cancel' part_pkg option will
789 If there is an error, returns the error, otherwise returns false.
794 my( $self, %options ) = @_;
797 # pass all suspend/cancel actions to the main package
798 # (unless the pkglinknum has been removed, then the link is defunct and
799 # this package can be canceled on its own)
800 if ( $self->main_pkgnum and $self->pkglinknum and !$options{'from_main'} ) {
801 return $self->main_pkg->cancel(%options);
804 my $conf = new FS::Conf;
806 warn "cust_pkg::cancel called with options".
807 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
810 my $oldAutoCommit = $FS::UID::AutoCommit;
811 local $FS::UID::AutoCommit = 0;
814 my $old = $self->select_for_update;
816 if ( $old->get('cancel') || $self->get('cancel') ) {
817 dbh->rollback if $oldAutoCommit;
818 return ""; # no error
821 # XXX possibly set cancel_time to the expire date?
822 my $cancel_time = $options{'time'} || time;
823 my $date = $options{'date'} if $options{'date'}; # expire/cancel later
824 $date = '' if ($date && $date <= $cancel_time); # complain instead?
826 my $delay_cancel = undef;
827 if ( !$date && $self->part_pkg->option('delay_cancel',1)
828 && (($self->status eq 'active') || ($self->status eq 'suspended'))
830 my $expdays = $conf->config('part_pkg-delay_cancel-days') || 1;
831 my $expsecs = 60*60*24*$expdays;
832 my $suspfor = $self->susp ? $cancel_time - $self->susp : 0;
833 $expsecs = $expsecs - $suspfor if $suspfor;
834 unless ($expsecs <= 0) { #if it's already been suspended long enough, don't re-suspend
836 $date = $cancel_time + $expsecs;
840 #race condition: usage could be ongoing until unprovisioned
841 #resolved by performing a change package instead (which unprovisions) and
843 if ( !$options{nobill} && !$date ) {
844 # && $conf->exists('bill_usage_on_cancel') ) { #calc_cancel checks this
845 my $copy = $self->new({$self->hash});
847 $copy->cust_main->bill( 'pkg_list' => [ $copy ],
849 'time' => $cancel_time );
850 warn "Error billing during cancel, custnum ".
851 #$self->cust_main->custnum. ": $error"
856 if ( $options{'reason'} ) {
857 $error = $self->insert_reason( 'reason' => $options{'reason'},
858 'action' => $date ? 'expire' : 'cancel',
859 'date' => $date ? $date : $cancel_time,
860 'reason_otaker' => $options{'reason_otaker'},
863 dbh->rollback if $oldAutoCommit;
864 return "Error inserting cust_pkg_reason: $error";
868 my %svc_cancel_opt = ();
869 $svc_cancel_opt{'date'} = $date if $date;
870 foreach my $cust_svc (
873 sort { $a->[1] <=> $b->[1] }
874 map { [ $_, $_->svc_x ? $_->svc_x->table_info->{'cancel_weight'} : -1 ]; }
875 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
877 my $part_svc = $cust_svc->part_svc;
878 next if ( defined($part_svc) and $part_svc->preserve );
879 my $error = $cust_svc->cancel( %svc_cancel_opt );
882 $dbh->rollback if $oldAutoCommit;
883 return 'Error '. ($svc_cancel_opt{'date'} ? 'expiring' : 'canceling' ).
889 # credit remaining time if appropriate
891 if ( exists($options{'unused_credit'}) ) {
892 $do_credit = $options{'unused_credit'};
895 $do_credit = $self->part_pkg->option('unused_credit_cancel', 1);
898 my $error = $self->credit_remaining('cancel', $cancel_time);
900 $dbh->rollback if $oldAutoCommit;
907 my %hash = $self->hash;
909 $hash{'expire'} = $date;
911 $hash{'susp'} = $cancel_time unless $self->susp;
912 $hash{'adjourn'} = undef;
913 $hash{'resume'} = undef;
916 $hash{'cancel'} = $cancel_time;
918 $hash{'change_custnum'} = $options{'change_custnum'};
920 # if this is a supplemental package that's lost its part_pkg_link, and it's
921 # being canceled for real, unlink it completely
922 if ( !$date and ! $self->pkglinknum ) {
923 $hash{main_pkgnum} = '';
926 my $new = new FS::cust_pkg ( \%hash );
927 $error = $new->replace( $self, options => { $self->options } );
928 if ( $self->change_to_pkgnum ) {
929 my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
930 $error ||= $change_to->cancel || $change_to->delete;
933 $dbh->rollback if $oldAutoCommit;
937 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
939 $error = $supp_pkg->suspend(%options, 'from_main' => 1, 'reason' => undef);
941 $error = $supp_pkg->cancel(%options, 'from_main' => 1);
944 $dbh->rollback if $oldAutoCommit;
945 return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
949 foreach my $usage ( $self->cust_pkg_usage ) {
950 $error = $usage->delete;
952 $dbh->rollback if $oldAutoCommit;
953 return "deleting usage pools: $error";
957 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
958 return '' if $date; #no errors
960 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
961 if ( !$options{'quiet'} &&
962 $conf->exists('emailcancel', $self->cust_main->agentnum) &&
964 my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
967 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
968 $error = $msg_template->send( 'cust_main' => $self->cust_main,
973 'from' => $conf->invoice_from_full( $self->cust_main->agentnum ),
974 'to' => \@invoicing_list,
975 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
976 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
977 'custnum' => $self->custnum,
978 'msgtype' => '', #admin?
981 #should this do something on errors?
988 =item cancel_if_expired [ NOW_TIMESTAMP ]
990 Cancels this package if its expire date has been reached.
994 sub cancel_if_expired {
996 my $time = shift || time;
997 return '' unless $self->expire && $self->expire <= $time;
998 my $error = $self->cancel;
1000 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
1001 $self->custnum. ": $error";
1008 "Un-cancels" this package: Orders a new package with the same custnum, pkgpart,
1009 locationnum, (other fields?). Attempts to re-provision cancelled services
1010 using history information (errors at this stage are not fatal).
1012 cust_pkg: pass a scalar reference, will be filled in with the new cust_pkg object
1014 svc_fatal: service provisioning errors are fatal
1016 svc_errors: pass an array reference, will be filled in with any provisioning errors
1018 main_pkgnum: link the package as a supplemental package of this one. For
1024 my( $self, %options ) = @_;
1026 #in case you try do do $uncancel-date = $cust_pkg->uncacel
1027 return '' unless $self->get('cancel');
1029 if ( $self->main_pkgnum and !$options{'main_pkgnum'} ) {
1030 return $self->main_pkg->uncancel(%options);
1037 my $oldAutoCommit = $FS::UID::AutoCommit;
1038 local $FS::UID::AutoCommit = 0;
1042 # insert the new package
1045 my $cust_pkg = new FS::cust_pkg {
1046 last_bill => ( $options{'last_bill'} || $self->get('last_bill') ),
1047 bill => ( $options{'bill'} || $self->get('bill') ),
1049 uncancel_pkgnum => $self->pkgnum,
1050 main_pkgnum => ($options{'main_pkgnum'} || ''),
1051 map { $_ => $self->get($_) } qw(
1052 custnum pkgpart locationnum
1054 susp adjourn resume expire start_date contract_end dundate
1055 change_date change_pkgpart change_locationnum
1056 manual_flag no_auto quantity agent_pkgid recur_show_zero setup_show_zero
1060 my $error = $cust_pkg->insert(
1061 'change' => 1, #supresses any referral credit to a referring customer
1062 'allow_pkgpart' => 1, # allow this even if the package def is disabled
1065 $dbh->rollback if $oldAutoCommit;
1073 #find historical services within this timeframe before the package cancel
1074 # (incompatible with "time" option to cust_pkg->cancel?)
1075 my $fuzz = 2 * 60; #2 minutes? too much? (might catch separate unprovision)
1076 # too little? (unprovisioing export delay?)
1077 my($end, $start) = ( $self->get('cancel'), $self->get('cancel') - $fuzz );
1078 my @h_cust_svc = $self->h_cust_svc( $end, $start );
1081 foreach my $h_cust_svc (@h_cust_svc) {
1082 my $h_svc_x = $h_cust_svc->h_svc_x( $end, $start );
1083 #next unless $h_svc_x; #should this happen?
1084 (my $table = $h_svc_x->table) =~ s/^h_//;
1085 require "FS/$table.pm";
1086 my $class = "FS::$table";
1087 my $svc_x = $class->new( {
1088 'pkgnum' => $cust_pkg->pkgnum,
1089 'svcpart' => $h_cust_svc->svcpart,
1090 map { $_ => $h_svc_x->get($_) } fields($table)
1094 if ( $h_svc_x->isa('FS::h_svc_Radius_Mixin') ) {
1095 $svc_x->usergroup( [ $h_svc_x->h_usergroup($end, $start) ] );
1098 my $svc_error = $svc_x->insert;
1100 if ( $options{svc_fatal} ) {
1101 $dbh->rollback if $oldAutoCommit;
1104 # if we've failed to insert the svc_x object, svc_Common->insert
1105 # will have removed the cust_svc already. if not, then both records
1106 # were inserted but we failed for some other reason (export, most
1107 # likely). in that case, report the error and delete the records.
1108 push @svc_errors, $svc_error;
1109 my $cust_svc = qsearchs('cust_svc', { 'svcnum' => $svc_x->svcnum });
1111 # except if export_insert failed, export_delete probably won't be
1113 local $FS::svc_Common::noexport_hack = 1;
1114 my $cleanup_error = $svc_x->delete; # also deletes cust_svc
1115 if ( $cleanup_error ) { # and if THAT fails, then run away
1116 $dbh->rollback if $oldAutoCommit;
1117 return $cleanup_error;
1122 } #foreach $h_cust_svc
1124 #these are pretty rare, but should handle them
1125 # - dsl_device (mac addresses)
1126 # - phone_device (mac addresses)
1127 # - dsl_note (ikano notes)
1128 # - domain_record (i.e. restore DNS information w/domains)
1129 # - inventory_item(?) (inventory w/un-cancelling service?)
1130 # - nas (svc_broaband nas stuff)
1131 #this stuff is unused in the wild afaik
1132 # - mailinglistmember
1134 # - svc_domain.parent_svcnum?
1135 # - acct_snarf (ancient mail fetching config)
1136 # - cgp_rule (communigate)
1137 # - cust_svc_option (used by our Tron stuff)
1138 # - acct_rt_transaction (used by our time worked stuff)
1141 # also move over any services that didn't unprovision at cancellation
1144 foreach my $cust_svc ( qsearch('cust_svc', { pkgnum => $self->pkgnum } ) ) {
1145 $cust_svc->pkgnum( $cust_pkg->pkgnum );
1146 my $error = $cust_svc->replace;
1148 $dbh->rollback if $oldAutoCommit;
1154 # Uncancel any supplemental packages, and make them supplemental to the
1158 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1160 $error = $supp_pkg->uncancel(%options, 'main_pkgnum' => $cust_pkg->pkgnum);
1162 $dbh->rollback if $oldAutoCommit;
1163 return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
1171 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1173 ${ $options{cust_pkg} } = $cust_pkg if ref($options{cust_pkg});
1174 @{ $options{svc_errors} } = @svc_errors if ref($options{svc_errors});
1181 Cancels any pending expiration (sets the expire field to null).
1183 If there is an error, returns the error, otherwise returns false.
1188 my( $self, %options ) = @_;
1191 my $oldAutoCommit = $FS::UID::AutoCommit;
1192 local $FS::UID::AutoCommit = 0;
1195 my $old = $self->select_for_update;
1197 my $pkgnum = $old->pkgnum;
1198 if ( $old->get('cancel') || $self->get('cancel') ) {
1199 dbh->rollback if $oldAutoCommit;
1200 return "Can't unexpire cancelled package $pkgnum";
1201 # or at least it's pointless
1204 unless ( $old->get('expire') && $self->get('expire') ) {
1205 dbh->rollback if $oldAutoCommit;
1206 return ""; # no error
1209 my %hash = $self->hash;
1210 $hash{'expire'} = '';
1211 my $new = new FS::cust_pkg ( \%hash );
1212 $error = $new->replace( $self, options => { $self->options } );
1214 $dbh->rollback if $oldAutoCommit;
1218 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1224 =item suspend [ OPTION => VALUE ... ]
1226 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1227 package, then suspends the package itself (sets the susp field to now).
1229 Available options are:
1233 =item reason - can be set to a cancellation reason (see L<FS:reason>),
1234 either a reasonnum of an existing reason, or passing a hashref will create
1235 a new reason. The hashref should have the following keys:
1236 - typenum - Reason type (see L<FS::reason_type>
1237 - reason - Text of the new reason.
1239 =item date - can be set to a unix style timestamp to specify when to
1242 =item time - can be set to override the current time, for calculation
1243 of final invoices or unused-time credits
1245 =item resume_date - can be set to a time when the package should be
1246 unsuspended. This may be more convenient than calling C<unsuspend()>
1249 =item from_main - allows a supplemental package to be suspended, rather
1250 than redirecting the method call to its main package. For internal use.
1254 If there is an error, returns the error, otherwise returns false.
1259 my( $self, %options ) = @_;
1262 # pass all suspend/cancel actions to the main package
1263 if ( $self->main_pkgnum and !$options{'from_main'} ) {
1264 return $self->main_pkg->suspend(%options);
1267 my $oldAutoCommit = $FS::UID::AutoCommit;
1268 local $FS::UID::AutoCommit = 0;
1271 my $old = $self->select_for_update;
1273 my $pkgnum = $old->pkgnum;
1274 if ( $old->get('cancel') || $self->get('cancel') ) {
1275 dbh->rollback if $oldAutoCommit;
1276 return "Can't suspend cancelled package $pkgnum";
1279 if ( $old->get('susp') || $self->get('susp') ) {
1280 dbh->rollback if $oldAutoCommit;
1281 return ""; # no error # complain on adjourn?
1284 my $suspend_time = $options{'time'} || time;
1285 my $date = $options{date} if $options{date}; # adjourn/suspend later
1286 $date = '' if ($date && $date <= $suspend_time); # complain instead?
1288 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
1289 dbh->rollback if $oldAutoCommit;
1290 return "Package $pkgnum expires before it would be suspended.";
1293 # some false laziness with sub cancel
1294 if ( !$options{nobill} && !$date &&
1295 $self->part_pkg->option('bill_suspend_as_cancel',1) ) {
1296 # kind of a kludge--'bill_suspend_as_cancel' to avoid having to
1297 # make the entire cust_main->bill path recognize 'suspend' and
1298 # 'cancel' separately.
1299 warn "Billing $pkgnum on suspension (at $suspend_time)\n" if $DEBUG;
1300 my $copy = $self->new({$self->hash});
1302 $copy->cust_main->bill( 'pkg_list' => [ $copy ],
1304 'time' => $suspend_time );
1305 warn "Error billing during suspend, custnum ".
1306 #$self->cust_main->custnum. ": $error"
1311 if ( $options{'reason'} ) {
1312 $error = $self->insert_reason( 'reason' => $options{'reason'},
1313 'action' => $date ? 'adjourn' : 'suspend',
1314 'date' => $date ? $date : $suspend_time,
1315 'reason_otaker' => $options{'reason_otaker'},
1318 dbh->rollback if $oldAutoCommit;
1319 return "Error inserting cust_pkg_reason: $error";
1323 # if a reasonnum was passed, get the actual reason object so we can check
1325 # (passing a reason hashref is still allowed, but it can't be used with
1326 # the fancy behavioral options.)
1329 if ($options{'reason'} =~ /^\d+$/) {
1330 $reason = FS::reason->by_key($options{'reason'});
1333 my %hash = $self->hash;
1335 $hash{'adjourn'} = $date;
1337 $hash{'susp'} = $suspend_time;
1340 my $resume_date = $options{'resume_date'} || 0;
1341 if ( $resume_date > ($date || $suspend_time) ) {
1342 $hash{'resume'} = $resume_date;
1345 $options{options} ||= {};
1347 my $new = new FS::cust_pkg ( \%hash );
1348 $error = $new->replace( $self, options => { $self->options,
1349 %{ $options{options} },
1353 $dbh->rollback if $oldAutoCommit;
1357 unless ( $date ) { # then we are suspending now
1359 # credit remaining time if appropriate
1360 # (if required by the package def, or the suspend reason)
1361 my $unused_credit = $self->part_pkg->option('unused_credit_suspend',1)
1362 || ( defined($reason) && $reason->unused_credit );
1364 if ( $unused_credit ) {
1365 warn "crediting unused time on pkg#".$self->pkgnum."\n" if $DEBUG;
1366 my $error = $self->credit_remaining('suspend', $suspend_time);
1368 $dbh->rollback if $oldAutoCommit;
1375 foreach my $cust_svc (
1376 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
1378 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1380 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1381 $dbh->rollback if $oldAutoCommit;
1382 return "Illegal svcdb value in part_svc!";
1385 require "FS/$svcdb.pm";
1387 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1389 $error = $svc->suspend;
1391 $dbh->rollback if $oldAutoCommit;
1394 my( $label, $value ) = $cust_svc->label;
1395 push @labels, "$label: $value";
1399 my $conf = new FS::Conf;
1400 if ( $conf->config('suspend_email_admin') ) {
1402 my $error = send_email(
1403 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1404 #invoice_from ??? well as good as any
1405 'to' => $conf->config('suspend_email_admin'),
1406 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
1408 "This is an automatic message from your Freeside installation\n",
1409 "informing you that the following customer package has been suspended:\n",
1411 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1412 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1413 ( map { "Service : $_\n" } @labels ),
1415 'custnum' => $self->custnum,
1416 'msgtype' => 'admin'
1420 warn "WARNING: can't send suspension admin email (suspending anyway): ".
1428 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1429 $error = $supp_pkg->suspend(%options, 'from_main' => 1);
1431 $dbh->rollback if $oldAutoCommit;
1432 return "suspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1436 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1441 =item credit_remaining MODE TIME
1443 Generate a credit for this package for the time remaining in the current
1444 billing period. MODE is either "suspend" or "cancel" (determines the
1445 credit type). TIME is the time of suspension/cancellation. Both arguments
1450 # Implementation note:
1452 # If you pkgpart-change a package that has been billed, and it's set to give
1453 # credit on package change, then this method gets called and then the new
1454 # package will have no last_bill date. Therefore the customer will be credited
1455 # only once (per billing period) even if there are multiple package changes.
1457 # If you location-change a package that has been billed, this method will NOT
1458 # be called and the new package WILL have the last bill date of the old
1461 # If the new package is then canceled within the same billing cycle,
1462 # credit_remaining needs to run calc_remain on the OLD package to determine
1463 # the amount of unused time to credit.
1465 sub credit_remaining {
1466 # Add a credit for remaining service
1467 my ($self, $mode, $time) = @_;
1468 die 'credit_remaining requires suspend or cancel'
1469 unless $mode eq 'suspend' or $mode eq 'cancel';
1470 die 'no suspend/cancel time' unless $time > 0;
1472 my $conf = FS::Conf->new;
1473 my $reason_type = $conf->config($mode.'_credit_type');
1475 my $last_bill = $self->getfield('last_bill') || 0;
1476 my $next_bill = $self->getfield('bill') || 0;
1477 if ( $last_bill > 0 # the package has been billed
1478 and $next_bill > 0 # the package has a next bill date
1479 and $next_bill >= $time # which is in the future
1481 my @cust_credit_source_bill_pkg = ();
1482 my $remaining_value = 0;
1484 my $remain_pkg = $self;
1485 $remaining_value = $remain_pkg->calc_remain(
1487 'cust_credit_source_bill_pkg' => \@cust_credit_source_bill_pkg,
1490 # we may have to walk back past some package changes to get to the
1491 # one that actually has unused time
1492 while ( $remaining_value == 0 ) {
1493 if ( $remain_pkg->change_pkgnum ) {
1494 $remain_pkg = FS::cust_pkg->by_key($remain_pkg->change_pkgnum);
1496 # the package has really never been billed
1499 $remaining_value = $remain_pkg->calc_remain(
1501 'cust_credit_source_bill_pkg' => \@cust_credit_source_bill_pkg,
1505 if ( $remaining_value > 0 ) {
1506 warn "Crediting for $remaining_value on package ".$self->pkgnum."\n"
1508 my $error = $self->cust_main->credit(
1510 'Credit for unused time on '. $self->part_pkg->pkg,
1511 'reason_type' => $reason_type,
1512 'cust_credit_source_bill_pkg' => \@cust_credit_source_bill_pkg,
1514 return "Error crediting customer \$$remaining_value for unused time".
1515 " on ". $self->part_pkg->pkg. ": $error"
1517 } #if $remaining_value
1518 } #if $last_bill, etc.
1522 =item unsuspend [ OPTION => VALUE ... ]
1524 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1525 package, then unsuspends the package itself (clears the susp field and the
1526 adjourn field if it is in the past). If the suspend reason includes an
1527 unsuspension package, that package will be ordered.
1529 Available options are:
1535 Can be set to a date to unsuspend the package in the future (the 'resume'
1538 =item adjust_next_bill
1540 Can be set true to adjust the next bill date forward by
1541 the amount of time the account was inactive. This was set true by default
1542 in the past (from 1.4.2 and 1.5.0pre6 through 1.7.0), but now needs to be
1543 explicitly requested with this option or in the price plan.
1547 If there is an error, returns the error, otherwise returns false.
1552 my( $self, %opt ) = @_;
1555 # pass all suspend/cancel actions to the main package
1556 if ( $self->main_pkgnum and !$opt{'from_main'} ) {
1557 return $self->main_pkg->unsuspend(%opt);
1560 my $oldAutoCommit = $FS::UID::AutoCommit;
1561 local $FS::UID::AutoCommit = 0;
1564 my $old = $self->select_for_update;
1566 my $pkgnum = $old->pkgnum;
1567 if ( $old->get('cancel') || $self->get('cancel') ) {
1568 $dbh->rollback if $oldAutoCommit;
1569 return "Can't unsuspend cancelled package $pkgnum";
1572 unless ( $old->get('susp') && $self->get('susp') ) {
1573 $dbh->rollback if $oldAutoCommit;
1574 return ""; # no error # complain instead?
1577 # handle the case of setting a future unsuspend (resume) date
1578 # and do not continue to actually unsuspend the package
1579 my $date = $opt{'date'};
1580 if ( $date and $date > time ) { # return an error if $date <= time?
1582 if ( $old->get('expire') && $old->get('expire') < $date ) {
1583 $dbh->rollback if $oldAutoCommit;
1584 return "Package $pkgnum expires before it would be unsuspended.";
1587 my $new = new FS::cust_pkg { $self->hash };
1588 $new->set('resume', $date);
1589 $error = $new->replace($self, options => $self->options);
1592 $dbh->rollback if $oldAutoCommit;
1596 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1602 if (!$self->setup) {
1603 # then this package is being released from on-hold status
1604 $self->set_initial_timers;
1609 foreach my $cust_svc (
1610 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1612 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1614 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1615 $dbh->rollback if $oldAutoCommit;
1616 return "Illegal svcdb value in part_svc!";
1619 require "FS/$svcdb.pm";
1621 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1623 $error = $svc->unsuspend;
1625 $dbh->rollback if $oldAutoCommit;
1628 my( $label, $value ) = $cust_svc->label;
1629 push @labels, "$label: $value";
1634 my $cust_pkg_reason = $self->last_cust_pkg_reason('susp');
1635 my $reason = $cust_pkg_reason ? $cust_pkg_reason->reason : '';
1637 my %hash = $self->hash;
1638 my $inactive = time - $hash{'susp'};
1640 my $conf = new FS::Conf;
1642 #adjust the next bill date forward
1643 # increment next bill date if certain conditions are met:
1644 # - it was due to be billed at some point
1645 # - either the global or local config says to do this
1646 my $adjust_bill = 0;
1649 && ( $hash{'bill'} || $hash{'setup'} )
1650 && ( $opt{'adjust_next_bill'}
1651 || $conf->exists('unsuspend-always_adjust_next_bill_date')
1652 || $self->part_pkg->option('unsuspend_adjust_bill', 1)
1659 # - the package billed during suspension
1660 # - or it was ordered on hold
1661 # - or the customer was credited for the unused time
1663 if ( $self->option('suspend_bill',1)
1664 or ( $self->part_pkg->option('suspend_bill',1)
1665 and ! $self->option('no_suspend_bill',1)
1667 or $hash{'order_date'} == $hash{'susp'}
1668 or $self->part_pkg->option('unused_credit_suspend')
1669 or ( ref($reason) and $reason->unused_credit )
1674 # then add the length of time suspended to the bill date
1675 if ( $adjust_bill ) {
1676 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
1680 $hash{'adjourn'} = '' if $hash{'adjourn'} and $hash{'adjourn'} < time;
1681 $hash{'resume'} = '' if !$hash{'adjourn'};
1682 my $new = new FS::cust_pkg ( \%hash );
1683 $error = $new->replace( $self, options => { $self->options } );
1685 $dbh->rollback if $oldAutoCommit;
1691 if ( $reason && $reason->unsuspend_pkgpart ) {
1692 my $part_pkg = FS::part_pkg->by_key($reason->unsuspend_pkgpart)
1693 or $error = "Unsuspend package definition ".$reason->unsuspend_pkgpart.
1695 my $start_date = $self->cust_main->next_bill_date
1696 if $reason->unsuspend_hold;
1699 $unsusp_pkg = FS::cust_pkg->new({
1700 'custnum' => $self->custnum,
1701 'pkgpart' => $reason->unsuspend_pkgpart,
1702 'start_date' => $start_date,
1703 'locationnum' => $self->locationnum,
1704 # discount? probably not...
1707 $error ||= $self->cust_main->order_pkg( 'cust_pkg' => $unsusp_pkg );
1711 $dbh->rollback if $oldAutoCommit;
1716 if ( $conf->config('unsuspend_email_admin') ) {
1718 my $error = send_email(
1719 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1720 #invoice_from ??? well as good as any
1721 'to' => $conf->config('unsuspend_email_admin'),
1722 'subject' => 'FREESIDE NOTIFICATION: Customer package unsuspended', 'body' => [
1723 "This is an automatic message from your Freeside installation\n",
1724 "informing you that the following customer package has been unsuspended:\n",
1726 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1727 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1728 ( map { "Service : $_\n" } @labels ),
1730 "An unsuspension fee was charged: ".
1731 $unsusp_pkg->part_pkg->pkg_comment."\n"
1735 'custnum' => $self->custnum,
1736 'msgtype' => 'admin',
1740 warn "WARNING: can't send unsuspension admin email (unsuspending anyway): ".
1746 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1747 $error = $supp_pkg->unsuspend(%opt, 'from_main' => 1);
1749 $dbh->rollback if $oldAutoCommit;
1750 return "unsuspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1754 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1761 Cancels any pending suspension (sets the adjourn field to null).
1763 If there is an error, returns the error, otherwise returns false.
1768 my( $self, %options ) = @_;
1771 my $oldAutoCommit = $FS::UID::AutoCommit;
1772 local $FS::UID::AutoCommit = 0;
1775 my $old = $self->select_for_update;
1777 my $pkgnum = $old->pkgnum;
1778 if ( $old->get('cancel') || $self->get('cancel') ) {
1779 dbh->rollback if $oldAutoCommit;
1780 return "Can't unadjourn cancelled package $pkgnum";
1781 # or at least it's pointless
1784 if ( $old->get('susp') || $self->get('susp') ) {
1785 dbh->rollback if $oldAutoCommit;
1786 return "Can't unadjourn suspended package $pkgnum";
1787 # perhaps this is arbitrary
1790 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1791 dbh->rollback if $oldAutoCommit;
1792 return ""; # no error
1795 my %hash = $self->hash;
1796 $hash{'adjourn'} = '';
1797 $hash{'resume'} = '';
1798 my $new = new FS::cust_pkg ( \%hash );
1799 $error = $new->replace( $self, options => { $self->options } );
1801 $dbh->rollback if $oldAutoCommit;
1805 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1812 =item change HASHREF | OPTION => VALUE ...
1814 Changes this package: cancels it and creates a new one, with a different
1815 pkgpart or locationnum or both. All services are transferred to the new
1816 package (no change will be made if this is not possible).
1818 Options may be passed as a list of key/value pairs or as a hash reference.
1825 New locationnum, to change the location for this package.
1829 New FS::cust_location object, to create a new location and assign it
1834 New FS::cust_main object, to create a new customer and assign the new package
1839 New pkgpart (see L<FS::part_pkg>).
1843 New refnum (see L<FS::part_referral>).
1847 New quantity; if unspecified, the new package will have the same quantity
1852 "New" (existing) FS::cust_pkg object. The package's services and other
1853 attributes will be transferred to this package.
1857 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
1858 susp, adjourn, cancel, expire, and contract_end) to the new package.
1860 =item unprotect_svcs
1862 Normally, change() will rollback and return an error if some services
1863 can't be transferred (also see the I<cust_pkg-change_svcpart> config option).
1864 If unprotect_svcs is true, this method will transfer as many services as
1865 it can and then unconditionally cancel the old package.
1869 At least one of locationnum, cust_location, pkgpart, refnum, cust_main, or
1870 cust_pkg must be specified (otherwise, what's the point?)
1872 Returns either the new FS::cust_pkg object or a scalar error.
1876 my $err_or_new_cust_pkg = $old_cust_pkg->change
1880 #some false laziness w/order
1883 my $opt = ref($_[0]) ? shift : { @_ };
1885 my $conf = new FS::Conf;
1887 # Transactionize this whole mess
1888 my $oldAutoCommit = $FS::UID::AutoCommit;
1889 local $FS::UID::AutoCommit = 0;
1898 $hash{'setup'} = $time if $self->setup;
1900 $hash{'change_date'} = $time;
1901 $hash{"change_$_"} = $self->$_()
1902 foreach qw( pkgnum pkgpart locationnum );
1904 if ( $opt->{'cust_location'} ) {
1905 $error = $opt->{'cust_location'}->find_or_insert;
1907 $dbh->rollback if $oldAutoCommit;
1908 return "creating location record: $error";
1910 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1913 if ( $opt->{'cust_pkg'} ) {
1914 # treat changing to a package with a different pkgpart as a
1915 # pkgpart change (because it is)
1916 $opt->{'pkgpart'} = $opt->{'cust_pkg'}->pkgpart;
1919 # whether to override pkgpart checking on the new package
1920 my $same_pkgpart = 1;
1921 if ( $opt->{'pkgpart'} and ( $opt->{'pkgpart'} != $self->pkgpart ) ) {
1925 my $unused_credit = 0;
1926 my $keep_dates = $opt->{'keep_dates'};
1927 # Special case. If the pkgpart is changing, and the customer is
1928 # going to be credited for remaining time, don't keep setup, bill,
1929 # or last_bill dates, and DO pass the flag to cancel() to credit
1931 if ( $opt->{'pkgpart'}
1932 and $opt->{'pkgpart'} != $self->pkgpart
1933 and $self->part_pkg->option('unused_credit_change', 1) ) {
1936 $hash{$_} = '' foreach qw(setup bill last_bill);
1939 if ( $keep_dates ) {
1940 foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1941 resume start_date contract_end ) ) {
1942 $hash{$date} = $self->getfield($date);
1945 # always keep this date, regardless of anything
1946 # (the date of the package change is in a different field)
1947 $hash{'order_date'} = $self->getfield('order_date');
1949 # allow $opt->{'locationnum'} = '' to specifically set it to null
1950 # (i.e. customer default location)
1951 $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
1953 # usually this doesn't matter. the two cases where it does are:
1954 # 1. unused_credit_change + pkgpart change + setup fee on the new package
1956 # 2. (more importantly) changing a package before it's billed
1957 $hash{'waive_setup'} = $self->waive_setup;
1959 my $custnum = $self->custnum;
1960 if ( $opt->{cust_main} ) {
1961 my $cust_main = $opt->{cust_main};
1962 unless ( $cust_main->custnum ) {
1963 my $error = $cust_main->insert( @{ $opt->{cust_main_insert_args}||[] } );
1965 $dbh->rollback if $oldAutoCommit;
1966 return "inserting customer record: $error";
1969 $custnum = $cust_main->custnum;
1972 $hash{'contactnum'} = $opt->{'contactnum'} if $opt->{'contactnum'};
1975 if ( $opt->{'cust_pkg'} ) {
1976 # The target package already exists; update it to show that it was
1977 # changed from this package.
1978 $cust_pkg = $opt->{'cust_pkg'};
1980 foreach ( qw( pkgnum pkgpart locationnum ) ) {
1981 $cust_pkg->set("change_$_", $self->get($_));
1983 $cust_pkg->set('change_date', $time);
1984 $error = $cust_pkg->replace;
1987 # Create the new package.
1988 $cust_pkg = new FS::cust_pkg {
1989 custnum => $custnum,
1990 locationnum => $opt->{'locationnum'},
1991 ( map { $_ => ( $opt->{$_} || $self->$_() ) }
1992 qw( pkgpart quantity refnum salesnum )
1996 $error = $cust_pkg->insert( 'change' => 1,
1997 'allow_pkgpart' => $same_pkgpart );
2000 $dbh->rollback if $oldAutoCommit;
2001 return "inserting new package: $error";
2004 # Transfer services and cancel old package.
2006 $error = $self->transfer($cust_pkg);
2007 if ($error and $error == 0) {
2008 # $old_pkg->transfer failed.
2009 $dbh->rollback if $oldAutoCommit;
2010 return "transferring $error";
2013 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2014 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2015 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
2016 if ($error and $error == 0) {
2017 # $old_pkg->transfer failed.
2018 $dbh->rollback if $oldAutoCommit;
2019 return "converting $error";
2023 # We set unprotect_svcs when executing a "future package change". It's
2024 # not a user-interactive operation, so returning an error means the
2025 # package change will just fail. Rather than have that happen, we'll
2026 # let leftover services be deleted.
2027 if ($error > 0 and !$opt->{'unprotect_svcs'}) {
2028 # Transfers were successful, but we still had services left on the old
2029 # package. We can't change the package under this circumstances, so abort.
2030 $dbh->rollback if $oldAutoCommit;
2031 return "unable to transfer all services";
2034 #reset usage if changing pkgpart
2035 # AND usage rollover is off (otherwise adds twice, now and at package bill)
2036 if ($self->pkgpart != $cust_pkg->pkgpart) {
2037 my $part_pkg = $cust_pkg->part_pkg;
2038 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
2042 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
2045 $dbh->rollback if $oldAutoCommit;
2046 return "setting usage values: $error";
2049 # if NOT changing pkgpart, transfer any usage pools over
2050 foreach my $usage ($self->cust_pkg_usage) {
2051 $usage->set('pkgnum', $cust_pkg->pkgnum);
2052 $error = $usage->replace;
2054 $dbh->rollback if $oldAutoCommit;
2055 return "transferring usage pools: $error";
2060 # transfer usage pricing add-ons, if we're not changing pkgpart
2061 if ( $same_pkgpart ) {
2062 foreach my $old_cust_pkg_usageprice ($self->cust_pkg_usageprice) {
2063 my $new_cust_pkg_usageprice = new FS::cust_pkg_usageprice {
2064 'pkgnum' => $cust_pkg->pkgnum,
2065 'usagepricepart' => $old_cust_pkg_usageprice->usagepricepart,
2066 'quantity' => $old_cust_pkg_usageprice->quantity,
2068 $error = $new_cust_pkg_usageprice->insert;
2070 $dbh->rollback if $oldAutoCommit;
2071 return "Error transferring usage pricing add-on: $error";
2076 # transfer discounts, if we're not changing pkgpart
2077 if ( $same_pkgpart ) {
2078 foreach my $old_discount ($self->cust_pkg_discount_active) {
2079 # don't remove the old discount, we may still need to bill that package.
2080 my $new_discount = new FS::cust_pkg_discount {
2081 'pkgnum' => $cust_pkg->pkgnum,
2082 'discountnum' => $old_discount->discountnum,
2083 'months_used' => $old_discount->months_used,
2085 $error = $new_discount->insert;
2087 $dbh->rollback if $oldAutoCommit;
2088 return "transferring discounts: $error";
2093 # transfer (copy) invoice details
2094 foreach my $detail ($self->cust_pkg_detail) {
2095 my $new_detail = FS::cust_pkg_detail->new({ $detail->hash });
2096 $new_detail->set('pkgdetailnum', '');
2097 $new_detail->set('pkgnum', $cust_pkg->pkgnum);
2098 $error = $new_detail->insert;
2100 $dbh->rollback if $oldAutoCommit;
2101 return "transferring package notes: $error";
2107 if ( !$opt->{'cust_pkg'} ) {
2108 # Order any supplemental packages.
2109 my $part_pkg = $cust_pkg->part_pkg;
2110 my @old_supp_pkgs = $self->supplemental_pkgs;
2111 foreach my $link ($part_pkg->supp_part_pkg_link) {
2113 foreach (@old_supp_pkgs) {
2114 if ($_->pkgpart == $link->dst_pkgpart) {
2116 $_->pkgpart(0); # so that it can't match more than once
2120 # false laziness with FS::cust_main::Packages::order_pkg
2121 my $new = FS::cust_pkg->new({
2122 pkgpart => $link->dst_pkgpart,
2123 pkglinknum => $link->pkglinknum,
2124 custnum => $custnum,
2125 main_pkgnum => $cust_pkg->pkgnum,
2126 locationnum => $cust_pkg->locationnum,
2127 start_date => $cust_pkg->start_date,
2128 order_date => $cust_pkg->order_date,
2129 expire => $cust_pkg->expire,
2130 adjourn => $cust_pkg->adjourn,
2131 contract_end => $cust_pkg->contract_end,
2132 refnum => $cust_pkg->refnum,
2133 discountnum => $cust_pkg->discountnum,
2134 waive_setup => $cust_pkg->waive_setup,
2136 if ( $old and $opt->{'keep_dates'} ) {
2137 foreach (qw(setup bill last_bill)) {
2138 $new->set($_, $old->get($_));
2141 $error = $new->insert( allow_pkgpart => $same_pkgpart );
2144 $error ||= $old->transfer($new);
2146 if ( $error and $error > 0 ) {
2147 # no reason why this should ever fail, but still...
2148 $error = "Unable to transfer all services from supplemental package ".
2152 $dbh->rollback if $oldAutoCommit;
2155 push @new_supp_pkgs, $new;
2157 } # if !$opt->{'cust_pkg'}
2158 # because if there is one, then supplemental packages would already
2159 # have been created for it.
2161 #Good to go, cancel old package. Notify 'cancel' of whether to credit
2163 #Don't allow billing the package (preceding period packages and/or
2164 #outstanding usage) if we are keeping dates (i.e. location changing),
2165 #because the new package will be billed for the same date range.
2166 #Supplemental packages are also canceled here.
2168 # during scheduled changes, avoid canceling the package we just
2170 $self->set('change_to_pkgnum' => '');
2172 $error = $self->cancel(
2174 unused_credit => $unused_credit,
2175 nobill => $keep_dates,
2176 change_custnum => ( $self->custnum != $custnum ? $custnum : '' ),
2179 $dbh->rollback if $oldAutoCommit;
2180 return "canceling old package: $error";
2183 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
2185 my $error = $cust_pkg->cust_main->bill(
2186 'pkg_list' => [ $cust_pkg, @new_supp_pkgs ]
2189 $dbh->rollback if $oldAutoCommit;
2190 return "billing new package: $error";
2194 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2200 =item change_later OPTION => VALUE...
2202 Schedule a package change for a later date. This actually orders the new
2203 package immediately, but sets its start date for a future date, and sets
2204 the current package to expire on the same date.
2206 If the package is already scheduled for a change, this can be called with
2207 'start_date' to change the scheduled date, or with pkgpart and/or
2208 locationnum to modify the package change. To cancel the scheduled change
2209 entirely, see C<abort_change>.
2217 The date for the package change. Required, and must be in the future.
2225 The pkgpart. locationnum, and quantity of the new package, with the same
2226 meaning as in C<change>.
2234 my $opt = ref($_[0]) ? shift : { @_ };
2236 my $oldAutoCommit = $FS::UID::AutoCommit;
2237 local $FS::UID::AutoCommit = 0;
2240 my $cust_main = $self->cust_main;
2242 my $date = delete $opt->{'start_date'} or return 'start_date required';
2244 if ( $date <= time ) {
2245 $dbh->rollback if $oldAutoCommit;
2246 return "start_date $date is in the past";
2251 if ( $self->change_to_pkgnum ) {
2252 my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
2253 my $new_pkgpart = $opt->{'pkgpart'}
2254 if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $change_to->pkgpart;
2255 my $new_locationnum = $opt->{'locationnum'}
2256 if $opt->{'locationnum'} and $opt->{'locationnum'} != $change_to->locationnum;
2257 my $new_quantity = $opt->{'quantity'}
2258 if $opt->{'quantity'} and $opt->{'quantity'} != $change_to->quantity;
2259 if ( $new_pkgpart or $new_locationnum or $new_quantity ) {
2260 # it hasn't been billed yet, so in principle we could just edit
2261 # it in place (w/o a package change), but that's bad form.
2262 # So change the package according to the new options...
2263 my $err_or_pkg = $change_to->change(%$opt);
2264 if ( ref $err_or_pkg ) {
2265 # Then set that package up for a future start.
2266 $self->set('change_to_pkgnum', $err_or_pkg->pkgnum);
2267 $self->set('expire', $date); # in case it's different
2268 $err_or_pkg->set('start_date', $date);
2269 $err_or_pkg->set('change_date', '');
2270 $err_or_pkg->set('change_pkgnum', '');
2272 $error = $self->replace ||
2273 $err_or_pkg->replace ||
2274 $change_to->cancel ||
2277 $error = $err_or_pkg;
2279 } else { # change the start date only.
2280 $self->set('expire', $date);
2281 $change_to->set('start_date', $date);
2282 $error = $self->replace || $change_to->replace;
2285 $dbh->rollback if $oldAutoCommit;
2288 $dbh->commit if $oldAutoCommit;
2291 } # if $self->change_to_pkgnum
2293 my $new_pkgpart = $opt->{'pkgpart'}
2294 if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $self->pkgpart;
2295 my $new_locationnum = $opt->{'locationnum'}
2296 if $opt->{'locationnum'} and $opt->{'locationnum'} != $self->locationnum;
2297 my $new_quantity = $opt->{'quantity'}
2298 if $opt->{'quantity'} and $opt->{'quantity'} != $self->quantity;
2300 return '' unless $new_pkgpart or $new_locationnum or $new_quantity; # wouldn't do anything
2302 # allow $opt->{'locationnum'} = '' to specifically set it to null
2303 # (i.e. customer default location)
2304 $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
2306 my $new = FS::cust_pkg->new( {
2307 custnum => $self->custnum,
2308 locationnum => $opt->{'locationnum'},
2309 start_date => $date,
2310 map { $_ => ( $opt->{$_} || $self->$_() ) }
2311 qw( pkgpart quantity refnum salesnum )
2313 $error = $new->insert('change' => 1,
2314 'allow_pkgpart' => ($new_pkgpart ? 0 : 1));
2316 $self->set('change_to_pkgnum', $new->pkgnum);
2317 $self->set('expire', $date);
2318 $error = $self->replace;
2321 $dbh->rollback if $oldAutoCommit;
2323 $dbh->commit if $oldAutoCommit;
2331 Cancels a future package change scheduled by C<change_later>.
2337 my $pkgnum = $self->change_to_pkgnum;
2338 my $change_to = FS::cust_pkg->by_key($pkgnum) if $pkgnum;
2341 $error = $change_to->cancel || $change_to->delete;
2342 return $error if $error;
2344 $self->set('change_to_pkgnum', '');
2345 $self->set('expire', '');
2349 =item set_quantity QUANTITY
2351 Change the package's quantity field. This is one of the few package properties
2352 that can safely be changed without canceling and reordering the package
2353 (because it doesn't affect tax eligibility). Returns an error or an
2360 $self = $self->replace_old; # just to make sure
2361 $self->quantity(shift);
2365 =item set_salesnum SALESNUM
2367 Change the package's salesnum (sales person) field. This is one of the few
2368 package properties that can safely be changed without canceling and reordering
2369 the package (because it doesn't affect tax eligibility). Returns an error or
2376 $self = $self->replace_old; # just to make sure
2377 $self->salesnum(shift);
2379 # XXX this should probably reassign any credit that's already been given
2382 =item modify_charge OPTIONS
2384 Change the properties of a one-time charge. The following properties can
2385 be changed this way:
2386 - pkg: the package description
2387 - classnum: the package class
2388 - additional: arrayref of additional invoice details to add to this package
2390 and, I<if the charge has not yet been billed>:
2391 - start_date: the date when it will be billed
2392 - amount: the setup fee to be charged
2393 - quantity: the multiplier for the setup fee
2395 If you pass 'adjust_commission' => 1, and the classnum changes, and there are
2396 commission credits linked to this charge, they will be recalculated.
2403 my $part_pkg = $self->part_pkg;
2404 my $pkgnum = $self->pkgnum;
2407 my $oldAutoCommit = $FS::UID::AutoCommit;
2408 local $FS::UID::AutoCommit = 0;
2410 return "Can't use modify_charge except on one-time charges"
2411 unless $part_pkg->freq eq '0';
2413 if ( length($opt{'pkg'}) and $part_pkg->pkg ne $opt{'pkg'} ) {
2414 $part_pkg->set('pkg', $opt{'pkg'});
2417 my %pkg_opt = $part_pkg->options;
2418 my $pkg_opt_modified = 0;
2420 $opt{'additional'} ||= [];
2423 foreach (grep /^additional/, keys %pkg_opt) {
2424 ($i) = ($_ =~ /^additional_info(\d+)$/);
2425 $old_additional[$i] = $pkg_opt{$_} if $i;
2426 delete $pkg_opt{$_};
2429 for ( $i = 0; exists($opt{'additional'}->[$i]); $i++ ) {
2430 $pkg_opt{ "additional_info$i" } = $opt{'additional'}->[$i];
2431 if (!exists($old_additional[$i])
2432 or $old_additional[$i] ne $opt{'additional'}->[$i])
2434 $pkg_opt_modified = 1;
2437 $pkg_opt_modified = 1 if (scalar(@old_additional) - 1) != $i;
2438 $pkg_opt{'additional_count'} = $i if $i > 0;
2441 if ( exists($opt{'classnum'}) and $part_pkg->classnum ne $opt{'classnum'} )
2444 $old_classnum = $part_pkg->classnum;
2445 $part_pkg->set('classnum', $opt{'classnum'});
2448 if ( !$self->get('setup') ) {
2449 # not yet billed, so allow amount, setup_cost, quantity and start_date
2451 if ( exists($opt{'amount'})
2452 and $part_pkg->option('setup_fee') != $opt{'amount'}
2453 and $opt{'amount'} > 0 ) {
2455 $pkg_opt{'setup_fee'} = $opt{'amount'};
2456 $pkg_opt_modified = 1;
2459 if ( exists($opt{'setup_cost'})
2460 and $part_pkg->setup_cost != $opt{'setup_cost'}
2461 and $opt{'setup_cost'} > 0 ) {
2463 $part_pkg->set('setup_cost', $opt{'setup_cost'});
2466 if ( exists($opt{'quantity'})
2467 and $opt{'quantity'} != $self->quantity
2468 and $opt{'quantity'} > 0 ) {
2470 $self->set('quantity', $opt{'quantity'});
2473 if ( exists($opt{'start_date'})
2474 and $opt{'start_date'} != $self->start_date ) {
2476 $self->set('start_date', $opt{'start_date'});
2480 } # else simply ignore them; the UI shouldn't allow editing the fields
2483 if ( exists($opt{'taxclass'})
2484 and $part_pkg->taxclass ne $opt{'taxclass'}) {
2486 $part_pkg->set('taxclass', $opt{'taxclass'});
2490 if ( $part_pkg->modified or $pkg_opt_modified ) {
2491 # can we safely modify the package def?
2492 # Yes, if it's not available for purchase, and this is the only instance
2494 if ( $part_pkg->disabled
2495 and FS::cust_pkg->count('pkgpart = '.$part_pkg->pkgpart) == 1
2496 and FS::quotation_pkg->count('pkgpart = '.$part_pkg->pkgpart) == 0
2498 $error = $part_pkg->replace( options => \%pkg_opt );
2501 $part_pkg = $part_pkg->clone;
2502 $part_pkg->set('disabled' => 'Y');
2503 $error = $part_pkg->insert( options => \%pkg_opt );
2504 # and associate this as yet-unbilled package to the new package def
2505 $self->set('pkgpart' => $part_pkg->pkgpart);
2508 $dbh->rollback if $oldAutoCommit;
2513 if ($self->modified) { # for quantity or start_date change, or if we had
2514 # to clone the existing package def
2515 my $error = $self->replace;
2516 return $error if $error;
2518 if (defined $old_classnum) {
2519 # fix invoice grouping records
2520 my $old_catname = $old_classnum
2521 ? FS::pkg_class->by_key($old_classnum)->categoryname
2523 my $new_catname = $opt{'classnum'}
2524 ? $part_pkg->pkg_class->categoryname
2526 if ( $old_catname ne $new_catname ) {
2527 foreach my $cust_bill_pkg ($self->cust_bill_pkg) {
2528 # (there should only be one...)
2529 my @display = qsearch( 'cust_bill_pkg_display', {
2530 'billpkgnum' => $cust_bill_pkg->billpkgnum,
2531 'section' => $old_catname,
2533 foreach (@display) {
2534 $_->set('section', $new_catname);
2535 $error = $_->replace;
2537 $dbh->rollback if $oldAutoCommit;
2541 } # foreach $cust_bill_pkg
2544 if ( $opt{'adjust_commission'} ) {
2545 # fix commission credits...tricky.
2546 foreach my $cust_event ($self->cust_event) {
2547 my $part_event = $cust_event->part_event;
2548 foreach my $table (qw(sales agent)) {
2550 "FS::part_event::Action::Mixin::credit_${table}_pkg_class";
2551 my $credit = qsearchs('cust_credit', {
2552 'eventnum' => $cust_event->eventnum,
2554 if ( $part_event->isa($class) ) {
2555 # Yes, this results in current commission rates being applied
2556 # retroactively to a one-time charge. For accounting purposes
2557 # there ought to be some kind of time limit on doing this.
2558 my $amount = $part_event->_calc_credit($self);
2559 if ( $credit and $credit->amount ne $amount ) {
2560 # Void the old credit.
2561 $error = $credit->void('Package class changed');
2563 $dbh->rollback if $oldAutoCommit;
2564 return "$error (adjusting commission credit)";
2567 # redo the event action to recreate the credit.
2569 eval { $part_event->do_action( $self, $cust_event ) };
2571 $dbh->rollback if $oldAutoCommit;
2574 } # if $part_event->isa($class)
2576 } # foreach $cust_event
2577 } # if $opt{'adjust_commission'}
2578 } # if defined $old_classnum
2580 $dbh->commit if $oldAutoCommit;
2587 sub process_bulk_cust_pkg {
2590 warn Dumper($param) if $DEBUG;
2592 my $old_part_pkg = qsearchs('part_pkg',
2593 { pkgpart => $param->{'old_pkgpart'} });
2594 my $new_part_pkg = qsearchs('part_pkg',
2595 { pkgpart => $param->{'new_pkgpart'} });
2596 die "Must select a new package type\n" unless $new_part_pkg;
2597 #my $keep_dates = $param->{'keep_dates'} || 0;
2598 my $keep_dates = 1; # there is no good reason to turn this off
2600 my $oldAutoCommit = $FS::UID::AutoCommit;
2601 local $FS::UID::AutoCommit = 0;
2604 my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
2607 foreach my $old_cust_pkg ( @cust_pkgs ) {
2609 $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
2610 if ( $old_cust_pkg->getfield('cancel') ) {
2611 warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
2612 $old_cust_pkg->pkgnum."\n"
2616 warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
2618 my $error = $old_cust_pkg->change(
2619 'pkgpart' => $param->{'new_pkgpart'},
2620 'keep_dates' => $keep_dates
2622 if ( !ref($error) ) { # change returns the cust_pkg on success
2624 die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
2627 $dbh->commit if $oldAutoCommit;
2633 Returns the last bill date, or if there is no last bill date, the setup date.
2634 Useful for billing metered services.
2640 return $self->setfield('last_bill', $_[0]) if @_;
2641 return $self->getfield('last_bill') if $self->getfield('last_bill');
2642 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
2643 'edate' => $self->bill, } );
2644 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
2647 =item last_cust_pkg_reason ACTION
2649 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
2650 Returns false if there is no reason or the package is not currenly ACTION'd
2651 ACTION is one of adjourn, susp, cancel, or expire.
2655 sub last_cust_pkg_reason {
2656 my ( $self, $action ) = ( shift, shift );
2657 my $date = $self->get($action);
2659 'table' => 'cust_pkg_reason',
2660 'hashref' => { 'pkgnum' => $self->pkgnum,
2661 'action' => substr(uc($action), 0, 1),
2664 'order_by' => 'ORDER BY num DESC LIMIT 1',
2668 =item last_reason ACTION
2670 Returns the most recent ACTION FS::reason associated with the package.
2671 Returns false if there is no reason or the package is not currenly ACTION'd
2672 ACTION is one of adjourn, susp, cancel, or expire.
2677 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
2678 $cust_pkg_reason->reason
2679 if $cust_pkg_reason;
2684 Returns the definition for this billing item, as an FS::part_pkg object (see
2691 return $self->{'_pkgpart'} if $self->{'_pkgpart'};
2692 cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
2693 qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
2698 Returns the cancelled package this package was changed from, if any.
2704 return '' unless $self->change_pkgnum;
2705 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
2708 =item change_cust_main
2710 Returns the customter this package was detached to, if any.
2714 sub change_cust_main {
2716 return '' unless $self->change_custnum;
2717 qsearchs('cust_main', { 'custnum' => $self->change_custnum } );
2722 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
2729 $self->part_pkg->calc_setup($self, @_);
2734 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
2741 $self->part_pkg->calc_recur($self, @_);
2746 Calls the I<base_setup> of the FS::part_pkg object associated with this billing
2753 $self->part_pkg->base_setup($self, @_);
2758 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
2765 $self->part_pkg->base_recur($self, @_);
2770 Calls the I<calc_remain> of the FS::part_pkg object associated with this
2777 $self->part_pkg->calc_remain($self, @_);
2782 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
2789 $self->part_pkg->calc_cancel($self, @_);
2794 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
2800 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
2803 =item cust_pkg_detail [ DETAILTYPE ]
2805 Returns any customer package details for this package (see
2806 L<FS::cust_pkg_detail>).
2808 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2812 sub cust_pkg_detail {
2814 my %hash = ( 'pkgnum' => $self->pkgnum );
2815 $hash{detailtype} = shift if @_;
2817 'table' => 'cust_pkg_detail',
2818 'hashref' => \%hash,
2819 'order_by' => 'ORDER BY weight, pkgdetailnum',
2823 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
2825 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
2827 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2829 If there is an error, returns the error, otherwise returns false.
2833 sub set_cust_pkg_detail {
2834 my( $self, $detailtype, @details ) = @_;
2836 my $oldAutoCommit = $FS::UID::AutoCommit;
2837 local $FS::UID::AutoCommit = 0;
2840 foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
2841 my $error = $current->delete;
2843 $dbh->rollback if $oldAutoCommit;
2844 return "error removing old detail: $error";
2848 foreach my $detail ( @details ) {
2849 my $cust_pkg_detail = new FS::cust_pkg_detail {
2850 'pkgnum' => $self->pkgnum,
2851 'detailtype' => $detailtype,
2852 'detail' => $detail,
2854 my $error = $cust_pkg_detail->insert;
2856 $dbh->rollback if $oldAutoCommit;
2857 return "error adding new detail: $error";
2862 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2869 Returns the customer billing events (see L<FS::cust_event>) for this invoice.
2873 #false laziness w/cust_bill.pm
2877 'table' => 'cust_event',
2878 'addl_from' => 'JOIN part_event USING ( eventpart )',
2879 'hashref' => { 'tablenum' => $self->pkgnum },
2880 'extra_sql' => " AND eventtable = 'cust_pkg' ",
2884 =item num_cust_event
2886 Returns the number of customer billing events (see L<FS::cust_event>) for this package.
2890 #false laziness w/cust_bill.pm
2891 sub num_cust_event {
2893 my $sql = "SELECT COUNT(*) ". $self->_from_cust_event_where;
2894 $self->_prep_ex($sql, $self->pkgnum)->fetchrow_arrayref->[0];
2897 =item exists_cust_event
2899 Returns true if there are customer billing events (see L<FS::cust_event>) for this package. More efficient than using num_cust_event.
2903 sub exists_cust_event {
2905 my $sql = "SELECT 1 ". $self->_from_cust_event_where. " LIMIT 1";
2906 my $row = $self->_prep_ex($sql, $self->pkgnum)->fetchrow_arrayref;
2907 $row ? $row->[0] : '';
2910 sub _from_cust_event_where {
2912 " FROM cust_event JOIN part_event USING ( eventpart ) ".
2913 " WHERE tablenum = ? AND eventtable = 'cust_pkg' ";
2917 my( $self, $sql, @args ) = @_;
2918 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
2919 $sth->execute(@args) or die $sth->errstr. " executing $sql";
2923 =item part_pkg_currency_option OPTIONNAME
2925 Returns a two item list consisting of the currency of this customer, if any,
2926 and a value for the provided option. If the customer has a currency, the value
2927 is the option value the given name and the currency (see
2928 L<FS::part_pkg_currency>). Otherwise, if the customer has no currency, is the
2929 regular option value for the given name (see L<FS::part_pkg_option>).
2933 sub part_pkg_currency_option {
2934 my( $self, $optionname ) = @_;
2935 my $part_pkg = $self->part_pkg;
2936 if ( my $currency = $self->cust_main->currency ) {
2937 ($currency, $part_pkg->part_pkg_currency_option($currency, $optionname) );
2939 ('', $part_pkg->option($optionname) );
2943 =item cust_svc [ SVCPART ] (old, deprecated usage)
2945 =item cust_svc [ OPTION => VALUE ... ] (current usage)
2947 =item cust_svc_unsorted [ OPTION => VALUE ... ]
2949 Returns the services for this package, as FS::cust_svc objects (see
2950 L<FS::cust_svc>). Available options are svcpart and svcdb. If either is
2951 spcififed, returns only the matching services.
2953 As an optimization, use the cust_svc_unsorted version if you are not displaying
2960 cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
2961 $self->_sort_cust_svc( $self->cust_svc_unsorted_arrayref(@_) );
2964 sub cust_svc_unsorted {
2966 @{ $self->cust_svc_unsorted_arrayref(@_) };
2969 sub cust_svc_unsorted_arrayref {
2972 return [] unless $self->num_cust_svc(@_);
2975 if ( @_ && $_[0] =~ /^\d+/ ) {
2976 $opt{svcpart} = shift;
2977 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2984 'table' => 'cust_svc',
2985 'hashref' => { 'pkgnum' => $self->pkgnum },
2987 if ( $opt{svcpart} ) {
2988 $search{hashref}->{svcpart} = $opt{'svcpart'};
2990 if ( $opt{'svcdb'} ) {
2991 $search{addl_from} = ' LEFT JOIN part_svc USING ( svcpart ) ';
2992 $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{'svcdb'} );
2995 [ qsearch(\%search) ];
2999 =item overlimit [ SVCPART ]
3001 Returns the services for this package which have exceeded their
3002 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
3003 is specified, return only the matching services.
3009 return () unless $self->num_cust_svc(@_);
3010 grep { $_->overlimit } $self->cust_svc(@_);
3013 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
3015 Returns historical services for this package created before END TIMESTAMP and
3016 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
3017 (see L<FS::h_cust_svc>). If MODE is 'I' (for 'invoice'), services with the
3018 I<pkg_svc.hidden> flag will be omitted.
3024 warn "$me _h_cust_svc called on $self\n"
3027 my ($end, $start, $mode) = @_;
3029 local($FS::Record::qsearch_qualify_columns) = 0;
3031 my @cust_svc = $self->_sort_cust_svc(
3032 [ qsearch( 'h_cust_svc',
3033 { 'pkgnum' => $self->pkgnum, },
3034 FS::h_cust_svc->sql_h_search(@_),
3038 if ( defined($mode) && $mode eq 'I' ) {
3039 my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
3040 return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
3046 sub _sort_cust_svc {
3047 my( $self, $arrayref ) = @_;
3050 sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] };
3052 my %pkg_svc = map { $_->svcpart => $_ }
3053 qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
3058 my $pkg_svc = $pkg_svc{ $_->svcpart } || '';
3060 $pkg_svc ? $pkg_svc->primary_svc : '',
3061 $pkg_svc ? $pkg_svc->quantity : 0,
3068 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
3070 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
3072 Returns the number of services for this package. Available options are svcpart
3073 and svcdb. If either is spcififed, returns only the matching services.
3080 return $self->{'_num_cust_svc'}
3082 && exists($self->{'_num_cust_svc'})
3083 && $self->{'_num_cust_svc'} =~ /\d/;
3085 cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
3089 if ( @_ && $_[0] =~ /^\d+/ ) {
3090 $opt{svcpart} = shift;
3091 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
3097 my $select = 'SELECT COUNT(*) FROM cust_svc ';
3098 my $where = ' WHERE pkgnum = ? ';
3099 my @param = ($self->pkgnum);
3101 if ( $opt{'svcpart'} ) {
3102 $where .= ' AND svcpart = ? ';
3103 push @param, $opt{'svcpart'};
3105 if ( $opt{'svcdb'} ) {
3106 $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
3107 $where .= ' AND svcdb = ? ';
3108 push @param, $opt{'svcdb'};
3111 my $sth = dbh->prepare("$select $where") or die dbh->errstr;
3112 $sth->execute(@param) or die $sth->errstr;
3113 $sth->fetchrow_arrayref->[0];
3116 =item available_part_svc
3118 Returns a list of FS::part_svc objects representing services included in this
3119 package but not yet provisioned. Each FS::part_svc object also has an extra
3120 field, I<num_avail>, which specifies the number of available services.
3124 sub available_part_svc {
3127 my $pkg_quantity = $self->quantity || 1;
3129 grep { $_->num_avail > 0 }
3131 my $part_svc = $_->part_svc;
3132 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
3133 $pkg_quantity * $_->quantity - $self->num_cust_svc($_->svcpart);
3135 # more evil encapsulation breakage
3136 if($part_svc->{'Hash'}{'num_avail'} > 0) {
3137 my @exports = $part_svc->part_export_did;
3138 $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
3143 $self->part_pkg->pkg_svc;
3146 =item part_svc [ OPTION => VALUE ... ]
3148 Returns a list of FS::part_svc objects representing provisioned and available
3149 services included in this package. Each FS::part_svc object also has the
3150 following extra fields:
3164 (services) - array reference containing the provisioned services, as cust_svc objects
3168 Accepts two options:
3172 =item summarize_size
3174 If true, will omit the extra cust_pkg_svc option for objects where num_cust_svc
3175 is this size or greater.
3177 =item hide_discontinued
3179 If true, will omit looking for services that are no longer avaialble in the
3187 #label -> ($cust_svc->label)[1]
3193 my $pkg_quantity = $self->quantity || 1;
3195 #XXX some sort of sort order besides numeric by svcpart...
3196 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
3198 my $part_svc = $pkg_svc->part_svc;
3199 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3200 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
3201 $part_svc->{'Hash'}{'num_avail'} =
3202 max( 0, $pkg_quantity * $pkg_svc->quantity - $num_cust_svc );
3203 $part_svc->{'Hash'}{'cust_pkg_svc'} =
3204 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
3205 unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
3206 && $num_cust_svc >= $opt{summarize_size};
3207 $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
3209 } $self->part_pkg->pkg_svc;
3211 unless ( $opt{hide_discontinued} ) {
3213 push @part_svc, map {
3215 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3216 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
3217 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
3218 $part_svc->{'Hash'}{'cust_pkg_svc'} =
3219 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
3221 } $self->extra_part_svc;
3228 =item extra_part_svc
3230 Returns a list of FS::part_svc objects corresponding to services in this
3231 package which are still provisioned but not (any longer) available in the
3236 sub extra_part_svc {
3239 my $pkgnum = $self->pkgnum;
3240 #my $pkgpart = $self->pkgpart;
3243 # 'table' => 'part_svc',
3246 # "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
3247 # WHERE pkg_svc.svcpart = part_svc.svcpart
3248 # AND pkg_svc.pkgpart = ?
3251 # AND 0 < ( SELECT COUNT(*) FROM cust_svc
3252 # LEFT JOIN cust_pkg USING ( pkgnum )
3253 # WHERE cust_svc.svcpart = part_svc.svcpart
3256 # 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
3259 #seems to benchmark slightly faster... (or did?)
3261 my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
3262 my $pkgparts = join(',', @pkgparts);
3265 #'select' => 'DISTINCT ON (svcpart) part_svc.*',
3266 #MySQL doesn't grok DISINCT ON
3267 'select' => 'DISTINCT part_svc.*',
3268 'table' => 'part_svc',
3270 "LEFT JOIN pkg_svc ON ( pkg_svc.svcpart = part_svc.svcpart
3271 AND pkg_svc.pkgpart IN ($pkgparts)
3274 LEFT JOIN cust_svc ON ( cust_svc.svcpart = part_svc.svcpart )
3275 LEFT JOIN cust_pkg USING ( pkgnum )
3278 'extra_sql' => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
3279 'extra_param' => [ [$self->pkgnum=>'int'] ],
3285 Returns a short status string for this package, currently:
3291 =item not yet billed
3293 =item one-time charge
3308 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
3310 return 'cancelled' if $self->get('cancel');
3311 return 'on hold' if $self->susp && ! $self->setup;
3312 return 'suspended' if $self->susp;
3313 return 'not yet billed' unless $self->setup;
3314 return 'one-time charge' if $freq =~ /^(0|$)/;
3318 =item ucfirst_status
3320 Returns the status with the first character capitalized.
3324 sub ucfirst_status {
3325 ucfirst(shift->status);
3330 Class method that returns the list of possible status strings for packages
3331 (see L<the status method|/status>). For example:
3333 @statuses = FS::cust_pkg->statuses();
3337 tie my %statuscolor, 'Tie::IxHash',
3338 'on hold' => 'FF00F5', #brighter purple!
3339 'not yet billed' => '009999', #teal? cyan?
3340 'one-time charge' => '0000CC', #blue #'000000',
3341 'active' => '00CC00',
3342 'suspended' => 'FF9900',
3343 'cancelled' => 'FF0000',
3347 my $self = shift; #could be class...
3348 #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
3349 # # mayble split btw one-time vs. recur
3360 Returns a hex triplet color string for this package's status.
3366 $statuscolor{$self->status};
3369 =item is_status_delay_cancel
3371 Returns true if part_pkg has option delay_cancel,
3372 cust_pkg status is 'suspended' and expire is set
3373 to cancel package within the next day (or however
3374 many days are set in global config part_pkg-delay_cancel-days.
3376 This is not a real status, this only meant for hacking display
3377 values, because otherwise treating the package as suspended is
3378 really the whole point of the delay_cancel option.
3382 sub is_status_delay_cancel {
3384 return 0 unless $self->part_pkg->option('delay_cancel',1);
3385 return 0 unless $self->status eq 'suspended';
3386 return 0 unless $self->expire;
3387 my $conf = new FS::Conf;
3388 my $expdays = $conf->config('part_pkg-delay_cancel-days') || 1;
3389 my $expsecs = 60*60*24*$expdays;
3390 return 0 unless $self->expire < time + $expsecs;
3396 Returns a label for this package. (Currently "pkgnum: pkg - comment" or
3397 "pkg - comment" depending on user preference).
3403 my $label = $self->part_pkg->pkg_comment( cust_pkg=>$self, nopkgpart=>1 );
3404 $label = $self->pkgnum. ": $label"
3405 if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
3409 =item pkg_label_long
3411 Returns a long label for this package, adding the primary service's label to
3416 sub pkg_label_long {
3418 my $label = $self->pkg_label;
3419 my $cust_svc = $self->primary_cust_svc;
3420 $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
3426 Returns a customer-localized label for this package.
3432 $self->part_pkg->pkg_locale( $self->cust_main->locale );
3435 =item primary_cust_svc
3437 Returns a primary service (as FS::cust_svc object) if one can be identified.
3441 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
3443 sub primary_cust_svc {
3446 my @cust_svc = $self->cust_svc;
3448 return '' unless @cust_svc; #no serivces - irrelevant then
3450 return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
3452 # primary service as specified in the package definition
3453 # or exactly one service definition with quantity one
3454 my $svcpart = $self->part_pkg->svcpart;
3455 @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
3456 return $cust_svc[0] if scalar(@cust_svc) == 1;
3458 #couldn't identify one thing..
3464 Returns a list of lists, calling the label method for all services
3465 (see L<FS::cust_svc>) of this billing item.
3471 map { [ $_->label ] } $self->cust_svc;
3474 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
3476 Like the labels method, but returns historical information on services that
3477 were active as of END_TIMESTAMP and (optionally) not cancelled before
3478 START_TIMESTAMP. If MODE is 'I' (for 'invoice'), services with the
3479 I<pkg_svc.hidden> flag will be omitted.
3481 Returns a list of lists, calling the label method for all (historical) services
3482 (see L<FS::h_cust_svc>) of this billing item.
3488 warn "$me _h_labels called on $self\n"
3490 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
3495 Like labels, except returns a simple flat list, and shortens long
3496 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3497 identical services to one line that lists the service label and the number of
3498 individual services rather than individual items.
3503 shift->_labels_short( 'labels', @_ );
3506 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
3508 Like h_labels, except returns a simple flat list, and shortens long
3509 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3510 identical services to one line that lists the service label and the number of
3511 individual services rather than individual items.
3515 sub h_labels_short {
3516 shift->_labels_short( 'h_labels', @_ );
3520 my( $self, $method ) = ( shift, shift );
3522 warn "$me _labels_short called on $self with $method method\n"
3525 my $conf = new FS::Conf;
3526 my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
3528 warn "$me _labels_short populating \%labels\n"
3532 #tie %labels, 'Tie::IxHash';
3533 push @{ $labels{$_->[0]} }, $_->[1]
3534 foreach $self->$method(@_);
3536 warn "$me _labels_short populating \@labels\n"
3540 foreach my $label ( keys %labels ) {
3542 my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
3543 my $num = scalar(@values);
3544 warn "$me _labels_short $num items for $label\n"
3547 if ( $num > $max_same_services ) {
3548 warn "$me _labels_short more than $max_same_services, so summarizing\n"
3550 push @labels, "$label ($num)";
3552 if ( $conf->exists('cust_bill-consolidate_services') ) {
3553 warn "$me _labels_short consolidating services\n"
3555 # push @labels, "$label: ". join(', ', @values);
3557 my $detail = "$label: ";
3558 $detail .= shift(@values). ', '
3560 && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
3562 push @labels, $detail;
3564 warn "$me _labels_short done consolidating services\n"
3567 warn "$me _labels_short adding service data\n"
3569 push @labels, map { "$label: $_" } @values;
3580 Returns the parent customer object (see L<FS::cust_main>).
3584 Returns the balance for this specific package, when using
3585 experimental package balance.
3591 $self->cust_main->balance_pkgnum( $self->pkgnum );
3594 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
3598 Returns the location object, if any (see L<FS::cust_location>).
3600 =item cust_location_or_main
3602 If this package is associated with a location, returns the locaiton (see
3603 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
3605 =item location_label [ OPTION => VALUE ... ]
3607 Returns the label of the location object (see L<FS::cust_location>).
3611 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
3613 =item tax_locationnum
3615 Returns the foreign key to a L<FS::cust_location> object for calculating
3616 tax on this package, as determined by the C<tax-pkg_address> and
3617 C<tax-ship_address> configuration flags.
3621 sub tax_locationnum {
3623 my $conf = FS::Conf->new;
3624 if ( $conf->exists('tax-pkg_address') ) {
3625 return $self->locationnum;
3627 elsif ( $conf->exists('tax-ship_address') ) {
3628 return $self->cust_main->ship_locationnum;
3631 return $self->cust_main->bill_locationnum;
3637 Returns the L<FS::cust_location> object for tax_locationnum.
3643 my $conf = FS::Conf->new;
3644 if ( $conf->exists('tax-pkg_address') and $self->locationnum ) {
3645 return FS::cust_location->by_key($self->locationnum);
3647 elsif ( $conf->exists('tax-ship_address') ) {
3648 return $self->cust_main->ship_location;
3651 return $self->cust_main->bill_location;
3655 =item seconds_since TIMESTAMP
3657 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
3658 package have been online since TIMESTAMP, according to the session monitor.
3660 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
3661 L<Time::Local> and L<Date::Parse> for conversion functions.
3666 my($self, $since) = @_;
3669 foreach my $cust_svc (
3670 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
3672 $seconds += $cust_svc->seconds_since($since);
3679 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
3681 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
3682 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
3685 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3686 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
3692 sub seconds_since_sqlradacct {
3693 my($self, $start, $end) = @_;
3697 foreach my $cust_svc (
3699 my $part_svc = $_->part_svc;
3700 $part_svc->svcdb eq 'svc_acct'
3701 && scalar($part_svc->part_export_usage);
3704 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
3711 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
3713 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
3714 in this package for sessions ending between TIMESTAMP_START (inclusive) and
3718 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3719 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
3724 sub attribute_since_sqlradacct {
3725 my($self, $start, $end, $attrib) = @_;
3729 foreach my $cust_svc (
3731 my $part_svc = $_->part_svc;
3732 scalar($part_svc->part_export_usage);
3735 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
3747 my( $self, $value ) = @_;
3748 if ( defined($value) ) {
3749 $self->setfield('quantity', $value);
3751 $self->getfield('quantity') || 1;
3754 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
3756 Transfers as many services as possible from this package to another package.
3758 The destination package can be specified by pkgnum by passing an FS::cust_pkg
3759 object. The destination package must already exist.
3761 Services are moved only if the destination allows services with the correct
3762 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
3763 this option with caution! No provision is made for export differences
3764 between the old and new service definitions. Probably only should be used
3765 when your exports for all service definitions of a given svcdb are identical.
3766 (attempt a transfer without it first, to move all possible svcpart-matching
3769 Any services that can't be moved remain in the original package.
3771 Returns an error, if there is one; otherwise, returns the number of services
3772 that couldn't be moved.
3777 my ($self, $dest_pkgnum, %opt) = @_;
3783 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
3784 $dest = $dest_pkgnum;
3785 $dest_pkgnum = $dest->pkgnum;
3787 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
3790 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
3792 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
3793 $target{$pkg_svc->svcpart} = $pkg_svc->quantity * ( $dest->quantity || 1 );
3796 foreach my $cust_svc ($dest->cust_svc) {
3797 $target{$cust_svc->svcpart}--;
3800 my %svcpart2svcparts = ();
3801 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3802 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
3803 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
3804 next if exists $svcpart2svcparts{$svcpart};
3805 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
3806 $svcpart2svcparts{$svcpart} = [
3808 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
3810 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
3811 'svcpart' => $_ } );
3813 $pkg_svc ? $pkg_svc->primary_svc : '',
3814 $pkg_svc ? $pkg_svc->quantity : 0,
3818 grep { $_ != $svcpart }
3820 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
3822 warn "alternates for svcpart $svcpart: ".
3823 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
3829 foreach my $cust_svc ($self->cust_svc) {
3830 my $svcnum = $cust_svc->svcnum;
3831 if($target{$cust_svc->svcpart} > 0
3832 or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
3833 $target{$cust_svc->svcpart}--;
3834 my $new = new FS::cust_svc { $cust_svc->hash };
3835 $new->pkgnum($dest_pkgnum);
3836 $error = $new->replace($cust_svc);
3837 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3839 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
3840 warn "alternates to consider: ".
3841 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
3843 my @alternate = grep {
3844 warn "considering alternate svcpart $_: ".
3845 "$target{$_} available in new package\n"
3848 } @{$svcpart2svcparts{$cust_svc->svcpart}};
3850 warn "alternate(s) found\n" if $DEBUG;
3851 my $change_svcpart = $alternate[0];
3852 $target{$change_svcpart}--;
3853 my $new = new FS::cust_svc { $cust_svc->hash };
3854 $new->svcpart($change_svcpart);
3855 $new->pkgnum($dest_pkgnum);
3856 $error = $new->replace($cust_svc);
3864 my @label = $cust_svc->label;
3865 return "$label[0] $label[1]: $error";
3871 =item grab_svcnums SVCNUM, SVCNUM ...
3873 Change the pkgnum for the provided services to this packages. If there is an
3874 error, returns the error, otherwise returns false.
3882 my $oldAutoCommit = $FS::UID::AutoCommit;
3883 local $FS::UID::AutoCommit = 0;
3886 foreach my $svcnum (@svcnum) {
3887 my $cust_svc = qsearchs('cust_svc', { svcnum=>$svcnum } ) or do {
3888 $dbh->rollback if $oldAutoCommit;
3889 return "unknown svcnum $svcnum";
3891 $cust_svc->pkgnum( $self->pkgnum );
3892 my $error = $cust_svc->replace;
3894 $dbh->rollback if $oldAutoCommit;
3899 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3906 This method is deprecated. See the I<depend_jobnum> option to the insert and
3907 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
3911 #looks like this is still used by the order_pkg and change_pkg methods in
3912 # ClientAPI/MyAccount, need to look into those before removing
3916 my $oldAutoCommit = $FS::UID::AutoCommit;
3917 local $FS::UID::AutoCommit = 0;
3920 foreach my $cust_svc ( $self->cust_svc ) {
3921 #false laziness w/svc_Common::insert
3922 my $svc_x = $cust_svc->svc_x;
3923 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
3924 my $error = $part_export->export_insert($svc_x);
3926 $dbh->rollback if $oldAutoCommit;
3932 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3937 =item export_pkg_change OLD_CUST_PKG
3939 Calls the "pkg_change" export action for all services attached to this package.
3943 sub export_pkg_change {
3944 my( $self, $old ) = ( shift, shift );
3946 my $oldAutoCommit = $FS::UID::AutoCommit;
3947 local $FS::UID::AutoCommit = 0;
3950 foreach my $svc_x ( map $_->svc_x, $self->cust_svc ) {
3951 my $error = $svc_x->export('pkg_change', $self, $old);
3953 $dbh->rollback if $oldAutoCommit;
3958 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3965 Associates this package with a (suspension or cancellation) reason (see
3966 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
3969 Available options are:
3975 can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason. The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
3979 the access_user (see L<FS::access_user>) providing the reason
3987 the action (cancel, susp, adjourn, expire) associated with the reason
3991 If there is an error, returns the error, otherwise returns false.
3996 my ($self, %options) = @_;
3998 my $otaker = $options{reason_otaker} ||
3999 $FS::CurrentUser::CurrentUser->username;
4002 if ( $options{'reason'} =~ /^(\d+)$/ ) {
4006 } elsif ( ref($options{'reason'}) ) {
4008 return 'Enter a new reason (or select an existing one)'
4009 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
4011 my $reason = new FS::reason({
4012 'reason_type' => $options{'reason'}->{'typenum'},
4013 'reason' => $options{'reason'}->{'reason'},
4015 my $error = $reason->insert;
4016 return $error if $error;
4018 $reasonnum = $reason->reasonnum;
4021 return "Unparseable reason: ". $options{'reason'};
4024 my $cust_pkg_reason =
4025 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
4026 'reasonnum' => $reasonnum,
4027 'otaker' => $otaker,
4028 'action' => substr(uc($options{'action'}),0,1),
4029 'date' => $options{'date'}
4034 $cust_pkg_reason->insert;
4037 =item insert_discount
4039 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
4040 inserting a new discount on the fly (see L<FS::discount>).
4042 Available options are:
4050 If there is an error, returns the error, otherwise returns false.
4054 sub insert_discount {
4055 #my ($self, %options) = @_;
4058 my $cust_pkg_discount = new FS::cust_pkg_discount {
4059 'pkgnum' => $self->pkgnum,
4060 'discountnum' => $self->discountnum,
4062 'end_date' => '', #XXX
4063 #for the create a new discount case
4064 '_type' => $self->discountnum__type,
4065 'amount' => $self->discountnum_amount,
4066 'percent' => $self->discountnum_percent,
4067 'months' => $self->discountnum_months,
4068 'setup' => $self->discountnum_setup,
4069 #'disabled' => $self->discountnum_disabled,
4072 $cust_pkg_discount->insert;
4075 =item set_usage USAGE_VALUE_HASHREF
4077 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
4078 to which they should be set (see L<FS::svc_acct>). Currently seconds,
4079 upbytes, downbytes, and totalbytes are appropriate keys.
4081 All svc_accts which are part of this package have their values reset.
4086 my ($self, $valueref, %opt) = @_;
4088 #only svc_acct can set_usage for now
4089 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
4090 my $svc_x = $cust_svc->svc_x;
4091 $svc_x->set_usage($valueref, %opt)
4092 if $svc_x->can("set_usage");
4096 =item recharge USAGE_VALUE_HASHREF
4098 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
4099 to which they should be set (see L<FS::svc_acct>). Currently seconds,
4100 upbytes, downbytes, and totalbytes are appropriate keys.
4102 All svc_accts which are part of this package have their values incremented.
4107 my ($self, $valueref) = @_;
4109 #only svc_acct can set_usage for now
4110 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
4111 my $svc_x = $cust_svc->svc_x;
4112 $svc_x->recharge($valueref)
4113 if $svc_x->can("recharge");
4117 =item apply_usageprice
4121 sub apply_usageprice {
4124 my $oldAutoCommit = $FS::UID::AutoCommit;
4125 local $FS::UID::AutoCommit = 0;
4130 foreach my $cust_pkg_usageprice ( $self->cust_pkg_usageprice ) {
4131 $error ||= $cust_pkg_usageprice->apply;
4135 $dbh->rollback if $oldAutoCommit;
4136 die "error applying part_pkg_usageprice add-ons, pkgnum ". $self->pkgnum.
4139 $dbh->commit if $oldAutoCommit;
4145 =item cust_pkg_discount
4147 =item cust_pkg_discount_active
4151 sub cust_pkg_discount_active {
4153 grep { $_->status eq 'active' } $self->cust_pkg_discount;
4156 =item cust_pkg_usage
4158 Returns a list of all voice usage counters attached to this package.
4160 =item apply_usage OPTIONS
4162 Takes the following options:
4163 - cdr: a call detail record (L<FS::cdr>)
4164 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
4165 - minutes: the maximum number of minutes to be charged
4167 Finds available usage minutes for a call of this class, and subtracts
4168 up to that many minutes from the usage pool. If the usage pool is empty,
4169 and the C<cdr-minutes_priority> global config option is set, minutes may
4170 be taken from other calls as well. Either way, an allocation record will
4171 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
4172 number of minutes of usage applied to the call.
4177 my ($self, %opt) = @_;
4178 my $cdr = $opt{cdr};
4179 my $rate_detail = $opt{rate_detail};
4180 my $minutes = $opt{minutes};
4181 my $classnum = $rate_detail->classnum;
4182 my $pkgnum = $self->pkgnum;
4183 my $custnum = $self->custnum;
4185 my $oldAutoCommit = $FS::UID::AutoCommit;
4186 local $FS::UID::AutoCommit = 0;
4189 my $order = FS::Conf->new->config('cdr-minutes_priority');
4193 $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
4195 $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
4197 my @usage_recs = qsearch({
4198 'table' => 'cust_pkg_usage',
4199 'addl_from' => ' JOIN part_pkg_usage USING (pkgusagepart)'.
4200 ' JOIN cust_pkg USING (pkgnum)'.
4201 ' JOIN part_pkg_usage_class USING (pkgusagepart)',
4202 'select' => 'cust_pkg_usage.*',
4203 'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
4204 " ( cust_pkg.custnum = $custnum AND ".
4205 " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4206 $is_classnum . ' AND '.
4207 " cust_pkg_usage.minutes > 0",
4208 'order_by' => " ORDER BY priority ASC",
4211 my $orig_minutes = $minutes;
4213 while (!$error and $minutes > 0 and @usage_recs) {
4214 my $cust_pkg_usage = shift @usage_recs;
4215 $cust_pkg_usage->select_for_update;
4216 my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
4217 pkgusagenum => $cust_pkg_usage->pkgusagenum,
4218 acctid => $cdr->acctid,
4219 minutes => min($cust_pkg_usage->minutes, $minutes),
4221 $cust_pkg_usage->set('minutes',
4222 $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes
4224 $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
4225 $minutes -= $cdr_cust_pkg_usage->minutes;
4227 if ( $order and $minutes > 0 and !$error ) {
4228 # then try to steal minutes from another call
4230 'table' => 'cdr_cust_pkg_usage',
4231 'addl_from' => ' JOIN cust_pkg_usage USING (pkgusagenum)'.
4232 ' JOIN part_pkg_usage USING (pkgusagepart)'.
4233 ' JOIN cust_pkg USING (pkgnum)'.
4234 ' JOIN part_pkg_usage_class USING (pkgusagepart)'.
4235 ' JOIN cdr USING (acctid)',
4236 'select' => 'cdr_cust_pkg_usage.*',
4237 'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
4238 " ( cust_pkg.pkgnum = $pkgnum OR ".
4239 " ( cust_pkg.custnum = $custnum AND ".
4240 " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4241 " part_pkg_usage_class.classnum = $classnum",
4242 'order_by' => ' ORDER BY part_pkg_usage.priority ASC',
4244 if ( $order eq 'time' ) {
4245 # find CDRs that are using minutes, but have a later startdate
4247 my $startdate = $cdr->startdate;
4248 if ($startdate !~ /^\d+$/) {
4249 die "bad cdr startdate '$startdate'";
4251 $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
4252 # minimize needless reshuffling
4253 $search{'order_by'} .= ', cdr.startdate DESC';
4255 # XXX may not work correctly with rate_time schedules. Could
4256 # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
4258 $search{'addl_from'} .=
4259 ' JOIN rate_detail'.
4260 ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
4261 if ( $order eq 'rate_high' ) {
4262 $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
4263 $rate_detail->min_charge;
4264 $search{'order_by'} .= ', rate_detail.min_charge ASC';
4265 } elsif ( $order eq 'rate_low' ) {
4266 $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
4267 $rate_detail->min_charge;
4268 $search{'order_by'} .= ', rate_detail.min_charge DESC';
4270 # this should really never happen
4271 die "invalid cdr-minutes_priority value '$order'\n";
4274 my @cdr_usage_recs = qsearch(\%search);
4276 while (!$error and @cdr_usage_recs and $minutes > 0) {
4277 my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
4278 my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
4279 my $old_cdr = $cdr_cust_pkg_usage->cdr;
4280 $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
4281 $cdr_cust_pkg_usage->select_for_update;
4282 $old_cdr->select_for_update;
4283 $cust_pkg_usage->select_for_update;
4284 # in case someone else stole the usage from this CDR
4285 # while waiting for the lock...
4286 next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
4287 # steal the usage allocation and flag the old CDR for reprocessing
4288 $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
4289 # if the allocation is more minutes than we need, adjust it...
4290 my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
4292 $cdr_cust_pkg_usage->set('minutes', $minutes);
4293 $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
4294 $error = $cust_pkg_usage->replace;
4296 #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
4297 $error ||= $cdr_cust_pkg_usage->replace;
4298 # deduct the stolen minutes
4299 $minutes -= $cdr_cust_pkg_usage->minutes;
4301 # after all minute-stealing is done, reset the affected CDRs
4302 foreach (values %reproc_cdrs) {
4303 $error ||= $_->set_status('');
4304 # XXX or should we just call $cdr->rate right here?
4305 # it's not like we can create a loop this way, since the min_charge
4306 # or call time has to go monotonically in one direction.
4307 # we COULD get some very deep recursions going, though...
4309 } # if $order and $minutes
4312 die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
4314 $dbh->commit if $oldAutoCommit;
4315 return $orig_minutes - $minutes;
4319 =item supplemental_pkgs
4321 Returns a list of all packages supplemental to this one.
4325 sub supplemental_pkgs {
4327 qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
4332 Returns the package that this one is supplemental to, if any.
4338 if ( $self->main_pkgnum ) {
4339 return FS::cust_pkg->by_key($self->main_pkgnum);
4346 =head1 CLASS METHODS
4352 Returns an SQL expression identifying recurring packages.
4356 sub recurring_sql { "
4357 '0' != ( select freq from part_pkg
4358 where cust_pkg.pkgpart = part_pkg.pkgpart )
4363 Returns an SQL expression identifying one-time packages.
4368 '0' = ( select freq from part_pkg
4369 where cust_pkg.pkgpart = part_pkg.pkgpart )
4374 Returns an SQL expression identifying ordered packages (recurring packages not
4380 $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
4385 Returns an SQL expression identifying active packages.
4390 $_[0]->recurring_sql. "
4391 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4392 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4393 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
4396 =item not_yet_billed_sql
4398 Returns an SQL expression identifying packages which have not yet been billed.
4402 sub not_yet_billed_sql { "
4403 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
4404 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4405 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
4410 Returns an SQL expression identifying inactive packages (one-time packages
4411 that are otherwise unsuspended/uncancelled).
4415 sub inactive_sql { "
4416 ". $_[0]->onetime_sql(). "
4417 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4418 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4419 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
4424 Returns an SQL expression identifying on-hold packages.
4429 #$_[0]->recurring_sql(). ' AND '.
4431 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4432 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
4433 AND ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
4440 Returns an SQL expression identifying suspended packages.
4444 sub suspended_sql { susp_sql(@_); }
4446 #$_[0]->recurring_sql(). ' AND '.
4448 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4449 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
4450 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4457 Returns an SQL exprression identifying cancelled packages.
4461 sub cancelled_sql { cancel_sql(@_); }
4463 #$_[0]->recurring_sql(). ' AND '.
4464 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
4469 Returns an SQL expression to give the package status as a string.
4475 WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
4476 WHEN ( cust_pkg.susp IS NOT NULL AND cust_pkg.setup IS NULL ) THEN 'on hold'
4477 WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
4478 WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
4479 WHEN ".onetime_sql()." THEN 'one-time charge'
4486 Returns a list of two package counts. The first is a count of packages
4487 based on the supplied criteria and the second is the count of residential
4488 packages with those same criteria. Criteria are specified as in the search
4494 my ($class, $params) = @_;
4496 my $sql_query = $class->search( $params );
4498 my $count_sql = delete($sql_query->{'count_query'});
4499 $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4500 or die "couldn't parse count_sql";
4502 my $count_sth = dbh->prepare($count_sql)
4503 or die "Error preparing $count_sql: ". dbh->errstr;
4505 or die "Error executing $count_sql: ". $count_sth->errstr;
4506 my $count_arrayref = $count_sth->fetchrow_arrayref;
4508 return ( @$count_arrayref );
4512 =item tax_locationnum_sql
4514 Returns an SQL expression for the tax location for a package, based
4515 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4519 sub tax_locationnum_sql {
4520 my $conf = FS::Conf->new;
4521 if ( $conf->exists('tax-pkg_address') ) {
4522 'cust_pkg.locationnum';
4524 elsif ( $conf->exists('tax-ship_address') ) {
4525 'cust_main.ship_locationnum';
4528 'cust_main.bill_locationnum';
4534 Returns a list: the first item is an SQL fragment identifying matching
4535 packages/customers via location (taking into account shipping and package
4536 address taxation, if enabled), and subsequent items are the parameters to
4537 substitute for the placeholders in that fragment.
4542 my($class, %opt) = @_;
4543 my $ornull = $opt{'ornull'};
4545 my $conf = new FS::Conf;
4547 # '?' placeholders in _location_sql_where
4548 my $x = $ornull ? 3 : 2;
4559 if ( $conf->exists('tax-ship_address') ) {
4562 ( ( ship_last IS NULL OR ship_last = '' )
4563 AND ". _location_sql_where('cust_main', '', $ornull ). "
4565 OR ( ship_last IS NOT NULL AND ship_last != ''
4566 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4569 # AND payby != 'COMP'
4571 @main_param = ( @bill_param, @bill_param );
4575 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4576 @main_param = @bill_param;
4582 if ( $conf->exists('tax-pkg_address') ) {
4584 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4587 ( cust_pkg.locationnum IS NULL AND $main_where )
4588 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
4591 @param = ( @main_param, @bill_param );
4595 $where = $main_where;
4596 @param = @main_param;
4604 #subroutine, helper for location_sql
4605 sub _location_sql_where {
4607 my $prefix = @_ ? shift : '';
4608 my $ornull = @_ ? shift : '';
4610 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4612 $ornull = $ornull ? ' OR ? IS NULL ' : '';
4614 my $or_empty_city = " OR ( ? = '' AND $table.${prefix}city IS NULL )";
4615 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL )";
4616 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL )";
4618 my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4620 # ( $table.${prefix}city = ? $or_empty_city $ornull )
4622 ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4623 AND ( $table.${prefix}city = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4624 AND ( $table.${prefix}county = ? $or_empty_county $ornull )
4625 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
4626 AND $table.${prefix}country = ?
4631 my( $self, $what ) = @_;
4633 my $what_show_zero = $what. '_show_zero';
4634 length($self->$what_show_zero())
4635 ? ($self->$what_show_zero() eq 'Y')
4636 : $self->part_pkg->$what_show_zero();
4643 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
4645 CUSTNUM is a customer (see L<FS::cust_main>)
4647 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4648 L<FS::part_pkg>) to order for this customer. Duplicates are of course
4651 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
4652 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
4653 new billing items. An error is returned if this is not possible (see
4654 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
4657 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4658 newly-created cust_pkg objects.
4660 REFNUM, if specified, will specify the FS::pkg_referral record to be created
4661 and inserted. Multiple FS::pkg_referral records can be created by
4662 setting I<refnum> to an array reference of refnums or a hash reference with
4663 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
4664 record will be created corresponding to cust_main.refnum.
4669 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
4671 my $conf = new FS::Conf;
4673 # Transactionize this whole mess
4674 my $oldAutoCommit = $FS::UID::AutoCommit;
4675 local $FS::UID::AutoCommit = 0;
4679 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
4680 # return "Customer not found: $custnum" unless $cust_main;
4682 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
4685 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4688 my $change = scalar(@old_cust_pkg) != 0;
4691 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
4693 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
4694 " to pkgpart ". $pkgparts->[0]. "\n"
4697 my $err_or_cust_pkg =
4698 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
4699 'refnum' => $refnum,
4702 unless (ref($err_or_cust_pkg)) {
4703 $dbh->rollback if $oldAutoCommit;
4704 return $err_or_cust_pkg;
4707 push @$return_cust_pkg, $err_or_cust_pkg;
4708 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4713 # Create the new packages.
4714 foreach my $pkgpart (@$pkgparts) {
4716 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
4718 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
4719 pkgpart => $pkgpart,
4723 $error = $cust_pkg->insert( 'change' => $change );
4724 push @$return_cust_pkg, $cust_pkg;
4726 foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
4727 my $supp_pkg = FS::cust_pkg->new({
4728 custnum => $custnum,
4729 pkgpart => $link->dst_pkgpart,
4731 main_pkgnum => $cust_pkg->pkgnum,
4734 $error ||= $supp_pkg->insert( 'change' => $change );
4735 push @$return_cust_pkg, $supp_pkg;
4739 $dbh->rollback if $oldAutoCommit;
4744 # $return_cust_pkg now contains refs to all of the newly
4747 # Transfer services and cancel old packages.
4748 foreach my $old_pkg (@old_cust_pkg) {
4750 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
4753 foreach my $new_pkg (@$return_cust_pkg) {
4754 $error = $old_pkg->transfer($new_pkg);
4755 if ($error and $error == 0) {
4756 # $old_pkg->transfer failed.
4757 $dbh->rollback if $oldAutoCommit;
4762 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
4763 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
4764 foreach my $new_pkg (@$return_cust_pkg) {
4765 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
4766 if ($error and $error == 0) {
4767 # $old_pkg->transfer failed.
4768 $dbh->rollback if $oldAutoCommit;
4775 # Transfers were successful, but we went through all of the
4776 # new packages and still had services left on the old package.
4777 # We can't cancel the package under the circumstances, so abort.
4778 $dbh->rollback if $oldAutoCommit;
4779 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
4781 $error = $old_pkg->cancel( quiet=>1 );
4787 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4791 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
4793 A bulk change method to change packages for multiple customers.
4795 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4796 L<FS::part_pkg>) to order for each customer. Duplicates are of course
4799 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
4800 replace. The services (see L<FS::cust_svc>) are moved to the
4801 new billing items. An error is returned if this is not possible (see
4804 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4805 newly-created cust_pkg objects.
4810 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
4812 # Transactionize this whole mess
4813 my $oldAutoCommit = $FS::UID::AutoCommit;
4814 local $FS::UID::AutoCommit = 0;
4818 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4821 while(scalar(@old_cust_pkg)) {
4823 my $custnum = $old_cust_pkg[0]->custnum;
4824 my (@remove) = map { $_->pkgnum }
4825 grep { $_->custnum == $custnum } @old_cust_pkg;
4826 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
4828 my $error = order $custnum, $pkgparts, \@remove, \@return;
4830 push @errors, $error
4832 push @$return_cust_pkg, @return;
4835 if (scalar(@errors)) {
4836 $dbh->rollback if $oldAutoCommit;
4837 return join(' / ', @errors);
4840 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4844 # Used by FS::Upgrade to migrate to a new database.
4845 sub _upgrade_data { # class method
4846 my ($class, %opts) = @_;
4847 $class->_upgrade_otaker(%opts);
4849 # RT#10139, bug resulting in contract_end being set when it shouldn't
4850 'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
4851 # RT#10830, bad calculation of prorate date near end of year
4852 # the date range for bill is December 2009, and we move it forward
4853 # one year if it's before the previous bill date (which it should
4855 'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
4856 AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
4857 WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
4858 # RT6628, add order_date to cust_pkg
4859 'update cust_pkg set order_date = (select history_date from h_cust_pkg
4860 where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
4861 history_action = \'insert\') where order_date is null',
4863 foreach my $sql (@statements) {
4864 my $sth = dbh->prepare($sql);
4865 $sth->execute or die $sth->errstr;
4868 # RT31194: supplemental package links that are deleted don't clean up
4870 my @pkglinknums = qsearch({
4871 'select' => 'DISTINCT cust_pkg.pkglinknum',
4872 'table' => 'cust_pkg',
4873 'addl_from' => ' LEFT JOIN part_pkg_link USING (pkglinknum) ',
4874 'extra_sql' => ' WHERE cust_pkg.pkglinknum IS NOT NULL
4875 AND part_pkg_link.pkglinknum IS NULL',
4877 foreach (@pkglinknums) {
4878 my $pkglinknum = $_->pkglinknum;
4879 warn "cleaning part_pkg_link #$pkglinknum\n";
4880 my $part_pkg_link = FS::part_pkg_link->new({pkglinknum => $pkglinknum});
4881 my $error = $part_pkg_link->remove_linked;
4882 die $error if $error;
4890 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
4892 In sub order, the @pkgparts array (passed by reference) is clobbered.
4894 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
4895 method to pass dates to the recur_prog expression, it should do so.
4897 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
4898 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
4899 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
4900 configuration values. Probably need a subroutine which decides what to do
4901 based on whether or not we've fetched the user yet, rather than a hash. See
4902 FS::UID and the TODO.
4904 Now that things are transactional should the check in the insert method be
4909 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
4910 L<FS::pkg_svc>, schema.html from the base documentation