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
9 use Carp qw(cluck croak);
10 use Scalar::Util qw( blessed );
11 use List::Util qw(min max sum);
13 use Time::Local qw( timelocal timelocal_nocheck );
15 use FS::UID qw( dbh driver_name );
16 use FS::Record qw( qsearch qsearchs fields );
22 use FS::cust_location;
24 use FS::cust_bill_pkg;
25 use FS::cust_pkg_detail;
26 use FS::cust_pkg_usage;
27 use FS::cdr_cust_pkg_usage;
32 use FS::cust_pkg_reason;
34 use FS::cust_pkg_usageprice;
35 use FS::cust_pkg_discount;
43 # temporary fix; remove this once (un)suspend admin notices are cleaned up
44 use FS::Misc qw(send_email);
46 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
48 # because they load configuration by setting FS::UID::callback (see TODO)
54 # for sending cancel emails in sub cancel
57 our ($disable_agentcheck, $DEBUG, $me, $import) = (0, 0, '[FS::cust_pkg]', 0);
59 our $upgrade = 0; #go away after setup+start dates cleaned up for old customers
61 our $cache_enabled = 0;
63 our $disable_start_on_hold = 0;
66 my( $self, $hashref ) = @_;
67 if ( $cache_enabled && $hashref->{'pkg'} && $hashref->{'plan'} ) {
68 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
74 my ( $hashref, $cache ) = @_;
75 # #if ( $hashref->{'pkgpart'} ) {
76 # if ( $hashref->{'pkg'} ) {
77 # # #@{ $self->{'_pkgnum'} } = ();
78 # # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
79 # # $self->{'_pkgpart'} = $subcache;
80 # # #push @{ $self->{'_pkgnum'} },
81 # # FS::part_pkg->new_or_cached($hashref, $subcache);
82 # $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
84 if ( exists $hashref->{'svcnum'} ) {
85 #@{ $self->{'_pkgnum'} } = ();
86 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
87 $self->{'_svcnum'} = $subcache;
88 #push @{ $self->{'_pkgnum'} },
89 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
95 FS::cust_pkg - Object methods for cust_pkg objects
101 $record = new FS::cust_pkg \%hash;
102 $record = new FS::cust_pkg { 'column' => 'value' };
104 $error = $record->insert;
106 $error = $new_record->replace($old_record);
108 $error = $record->delete;
110 $error = $record->check;
112 $error = $record->cancel;
114 $error = $record->suspend;
116 $error = $record->unsuspend;
118 $part_pkg = $record->part_pkg;
120 @labels = $record->labels;
122 $seconds = $record->seconds_since($timestamp);
124 #bulk cancel+order... perhaps slightly deprecated, only used by the bulk
125 # cancel+order in the web UI and nowhere else (edit/process/cust_pkg.cgi)
126 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
127 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
131 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
132 inherits from FS::Record. The following fields are currently supported:
138 Primary key (assigned automatically for new billing items)
142 Customer (see L<FS::cust_main>)
146 Billing item definition (see L<FS::part_pkg>)
150 Optional link to package location (see L<FS::cust_location>)
154 date package was ordered (also remains same on changes)
166 date (next bill date)
194 order taker (see L<FS::access_user>)
198 If not set, defaults to 1
202 Date of change from previous package
212 =item change_locationnum
220 The pkgnum of the package that this package is supplemental to, if any.
224 The package link (L<FS::part_pkg_link>) that defines this supplemental
225 package, if it is one.
227 =item change_to_pkgnum
229 The pkgnum of the package this one will be "changed to" in the future
230 (on its expiration date).
234 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
235 are specified as UNIX timestamps; see L<perlfunc/"time">. Also see
236 L<Time::Local> and L<Date::Parse> for conversion functions.
244 Create a new billing item. To add the item to the database, see L<"insert">.
248 sub table { 'cust_pkg'; }
249 sub cust_linked { $_[0]->cust_main_custnum || $_[0]->custnum }
250 sub cust_unlinked_msg {
252 "WARNING: can't find cust_main.custnum ". $self->custnum.
253 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
256 =item set_initial_timers
258 If required by the package definition, sets any automatic expire, adjourn,
259 or contract_end timers to some number of months after the start date
260 (or setup date, if the package has already been setup). If the package has
261 a delayed setup fee after a period of "free days", will also set the
262 start date to the end of that period.
264 If the package has an automatic transfer rule (C<change_to_pkgnum>), then
265 this will also order the package and set its start date.
269 sub set_initial_timers {
271 my $part_pkg = $self->part_pkg;
272 my $start = $self->start_date || $self->setup || time;
274 foreach my $action ( qw(expire adjourn contract_end) ) {
275 my $months = $part_pkg->get("${action}_months");
276 if($months and !$self->get($action)) {
277 $self->set($action, $part_pkg->add_freq($start, $months) );
281 # if this package has an expire date and a change_to_pkgpart, set automatic
283 # (but don't call change_later, as that would call $self->replace, and we're
284 # probably in the middle of $self->insert right now)
285 if ( $part_pkg->expire_months and $part_pkg->change_to_pkgpart ) {
286 if ( $self->change_to_pkgnum ) {
287 # this can happen if a package is ordered on hold, scheduled for a
288 # future change _while on hold_, and then released from hold, causing
289 # the automatic transfer to schedule.
291 # what's correct behavior in that case? I think it's to disallow
292 # future-changing an on-hold package that has an automatic transfer.
293 # but if we DO get into this situation, let the manual package change
295 warn "pkgnum ".$self->pkgnum.": manual future package change blocks ".
296 "automatic transfer.\n";
298 my $change_to = FS::cust_pkg->new( {
299 start_date => $self->get('expire'),
300 pkgpart => $part_pkg->change_to_pkgpart,
301 map { $_ => $self->get($_) }
302 qw( custnum locationnum quantity refnum salesnum contract_end )
304 my $error = $change_to->insert;
306 return $error if $error;
307 $self->set('change_to_pkgnum', $change_to->pkgnum);
311 # if this package has "free days" and delayed setup fee, then
312 # set start date that many days in the future.
313 # (this should have been set in the UI, but enforce it here)
314 if ( $part_pkg->option('free_days',1)
315 && $part_pkg->option('delay_setup',1)
318 $self->start_date( $part_pkg->default_start_date );
324 =item insert [ OPTION => VALUE ... ]
326 Adds this billing item to the database ("Orders" the item). If there is an
327 error, returns the error, otherwise returns false.
329 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
330 will be used to look up the package definition and agent restrictions will be
333 If the additional field I<refnum> is defined, an FS::pkg_referral record will
334 be created and inserted. Multiple FS::pkg_referral records can be created by
335 setting I<refnum> to an array reference of refnums or a hash reference with
336 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
337 record will be created corresponding to cust_main.refnum.
339 If the additional field I<cust_pkg_usageprice> is defined, it will be treated
340 as an arrayref of FS::cust_pkg_usageprice objects, which will be inserted.
341 (Note that this field cannot be set with a usual ->cust_pkg_usageprice method.
342 It can be set as part of the hash when creating the object, or with the B<set>
345 The following options are available:
351 If set true, supresses actions that should only be taken for new package
352 orders. (Currently this includes: intro periods when delay_setup is on,
353 auto-adding a 1st start date, auto-adding expiration/adjourn/contract_end dates)
357 cust_pkg_option records will be created
361 a ticket will be added to this customer with this subject
365 an optional queue name for ticket additions
369 Don't check the legality of the package definition. This should be used
370 when performing a package change that doesn't change the pkgpart (i.e.
378 my( $self, %options ) = @_;
380 my $oldAutoCommit = $FS::UID::AutoCommit;
381 local $FS::UID::AutoCommit = 0;
385 $error = $self->check_pkgpart unless $options{'allow_pkgpart'};
387 my $part_pkg = $self->part_pkg;
389 if ( ! $import && ! $options{'change'} ) {
391 # set order date to now
392 $self->order_date(time) unless ($import && $self->order_date);
394 # if the package def says to start only on the first of the month:
395 if ( $part_pkg->option('start_1st', 1) && !$self->start_date ) {
396 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
397 $mon += 1 unless $mday == 1;
398 until ( $mon < 12 ) { $mon -= 12; $year++; }
399 $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
402 if ( $self->susp eq 'now'
403 or ( $part_pkg->start_on_hold && ! $disable_start_on_hold )
406 # if the package was ordered on hold:
408 # - don't set the start date (it will be started manually)
409 $self->set('susp', $self->order_date);
410 $self->set('start_date', '');
412 # set expire/adjourn/contract_end timers, and free days, if appropriate
413 # and automatic package transfer, which can fail, so capture the result
414 $error = $self->set_initial_timers;
416 } # else this is a package change, and shouldn't have "new package" behavior
418 $error ||= $self->SUPER::insert($options{options} ? %{$options{options}} : ());
420 $dbh->rollback if $oldAutoCommit;
424 $self->refnum($self->cust_main->refnum) unless $self->refnum;
425 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
426 $self->process_m2m( 'link_table' => 'pkg_referral',
427 'target_table' => 'part_referral',
428 'params' => $self->refnum,
431 if ( $self->hashref->{cust_pkg_usageprice} ) {
432 for my $cust_pkg_usageprice ( @{ $self->hashref->{cust_pkg_usageprice} } ) {
433 $cust_pkg_usageprice->pkgnum( $self->pkgnum );
434 my $error = $cust_pkg_usageprice->insert;
436 $dbh->rollback if $oldAutoCommit;
442 if ( $self->setup_discountnum || $self->recur_discountnum ) {
443 my $error = $self->insert_discount();
445 $dbh->rollback if $oldAutoCommit;
450 my $conf = new FS::Conf;
452 if ($self->locationnum) {
454 map qsearch( 'part_export', {exportnum=>$_} ),
455 $conf->config('cust_location-exports'); #, $agentnum
457 foreach my $part_export ( @part_export ) {
458 my $error = $part_export->export_pkg_location($self); #, @$export_args);
460 $dbh->rollback if $oldAutoCommit;
461 return "exporting to ". $part_export->exporttype.
462 " (transaction rolled back): $error";
467 if ( ! $import && $conf->config('ticket_system') && $options{ticket_subject} ) {
469 #this init stuff is still inefficient, but at least its limited to
470 # the small number (any?) folks using ticket emailing on pkg order
473 # use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
480 use FS::TicketSystem;
481 FS::TicketSystem->init();
483 my $q = new RT::Queue($RT::SystemUser);
484 $q->Load($options{ticket_queue}) if $options{ticket_queue};
485 my $t = new RT::Ticket($RT::SystemUser);
486 my $mime = new MIME::Entity;
487 $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
488 $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
489 Subject => $options{ticket_subject},
492 $t->AddLink( Type => 'MemberOf',
493 Target => 'freeside://freeside/cust_main/'. $self->custnum,
497 if (! $import && $conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
498 my $queue = new FS::queue {
499 'job' => 'FS::cust_main::queueable_print',
501 $error = $queue->insert(
502 'custnum' => $self->custnum,
503 'template' => 'welcome_letter',
507 warn "can't send welcome letter: $error";
512 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
519 This method now works but you probably shouldn't use it.
521 You don't want to delete packages, because there would then be no record
522 the customer ever purchased the package. Instead, see the cancel method and
523 hide cancelled packages.
527 # this is still used internally to abort future package changes, so it
533 # The following foreign keys to cust_pkg are not cleaned up here, and will
534 # cause package deletion to fail:
536 # cust_credit.pkgnum and commission_pkgnum (and cust_credit_void)
537 # cust_credit_bill.pkgnum
538 # cust_pay_pending.pkgnum
539 # cust_pay.pkgnum (and cust_pay_void)
540 # cust_bill_pay.pkgnum (wtf, shouldn't reference pkgnum)
541 # cust_pkg_usage.pkgnum
542 # cust_pkg.uncancel_pkgnum, change_pkgnum, main_pkgnum, and change_to_pkgnum
543 # rt_field_charge.pkgnum
545 # cust_svc is handled by canceling the package before deleting it
546 # cust_pkg_option is handled via option_Common
548 my $oldAutoCommit = $FS::UID::AutoCommit;
549 local $FS::UID::AutoCommit = 0;
552 foreach my $cust_pkg_discount ($self->cust_pkg_discount) {
553 my $error = $cust_pkg_discount->delete;
555 $dbh->rollback if $oldAutoCommit;
559 #cust_bill_pkg_discount?
561 foreach my $cust_pkg_detail ($self->cust_pkg_detail) {
562 my $error = $cust_pkg_detail->delete;
564 $dbh->rollback if $oldAutoCommit;
569 foreach my $cust_pkg_reason (
571 'table' => 'cust_pkg_reason',
572 'hashref' => { 'pkgnum' => $self->pkgnum },
576 my $error = $cust_pkg_reason->delete;
578 $dbh->rollback if $oldAutoCommit;
583 foreach my $pkg_referral ( $self->pkg_referral ) {
584 my $error = $pkg_referral->delete;
586 $dbh->rollback if $oldAutoCommit;
591 my $error = $self->SUPER::delete(@_);
593 $dbh->rollback if $oldAutoCommit;
597 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
603 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
605 Replaces the OLD_RECORD with this one in the database. If there is an error,
606 returns the error, otherwise returns false.
608 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
610 Changing pkgpart may have disasterous effects. See the order subroutine.
612 setup and bill are normally updated by calling the bill method of a customer
613 object (see L<FS::cust_main>).
615 suspend is normally updated by the suspend and unsuspend methods.
617 cancel is normally updated by the cancel method (and also the order subroutine
620 Available options are:
626 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.
630 the access_user (see L<FS::access_user>) providing the reason
634 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
643 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
648 ( ref($_[0]) eq 'HASH' )
652 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
653 #return "Can't change otaker!" if $old->otaker ne $new->otaker;
656 #return "Can't change setup once it exists!"
657 # if $old->getfield('setup') &&
658 # $old->getfield('setup') != $new->getfield('setup');
660 #some logic for bill, susp, cancel?
662 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
664 my $oldAutoCommit = $FS::UID::AutoCommit;
665 local $FS::UID::AutoCommit = 0;
668 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
669 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
670 my $error = $new->insert_reason(
671 'reason' => $options->{'reason'},
672 'date' => $new->$method,
674 'reason_otaker' => $options->{'reason_otaker'},
677 dbh->rollback if $oldAutoCommit;
678 return "Error inserting cust_pkg_reason: $error";
683 #save off and freeze RADIUS attributes for any associated svc_acct records
685 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
687 #also check for specific exports?
688 # to avoid spurious modify export events
689 @svc_acct = map { $_->svc_x }
690 grep { $_->part_svc->svcdb eq 'svc_acct' }
693 $_->snapshot foreach @svc_acct;
697 my $error = $new->export_pkg_change($old)
698 || $new->SUPER::replace( $old,
700 ? $options->{options}
704 $dbh->rollback if $oldAutoCommit;
708 #for prepaid packages,
709 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
710 foreach my $old_svc_acct ( @svc_acct ) {
711 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
713 $new_svc_acct->replace( $old_svc_acct,
714 'depend_jobnum' => $options->{depend_jobnum},
717 $dbh->rollback if $oldAutoCommit;
722 # also run exports if removing locationnum?
723 # doesn't seem to happen, and we don't export blank locationnum on insert...
724 if ($new->locationnum and ($new->locationnum != $old->locationnum)) {
725 my $conf = new FS::Conf;
727 map qsearch( 'part_export', {exportnum=>$_} ),
728 $conf->config('cust_location-exports'); #, $agentnum
730 foreach my $part_export ( @part_export ) {
731 my $error = $part_export->export_pkg_location($new); #, @$export_args);
733 $dbh->rollback if $oldAutoCommit;
734 return "exporting to ". $part_export->exporttype.
735 " (transaction rolled back): $error";
740 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
747 Checks all fields to make sure this is a valid billing item. If there is an
748 error, returns the error, otherwise returns false. Called by the insert and
756 if ( !$self->locationnum or $self->locationnum == -1 ) {
757 $self->set('locationnum', $self->cust_main->ship_locationnum);
761 $self->ut_numbern('pkgnum')
762 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
763 || $self->ut_numbern('pkgpart')
764 || $self->ut_foreign_keyn('contactnum', 'contact', 'contactnum' )
765 || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
766 || $self->ut_foreign_keyn('salesnum', 'sales', 'salesnum')
767 || $self->ut_numbern('quantity')
768 || $self->ut_numbern('start_date')
769 || $self->ut_numbern('setup')
770 || $self->ut_numbern('bill')
771 || $self->ut_numbern('susp')
772 || $self->ut_numbern('cancel')
773 || $self->ut_numbern('adjourn')
774 || $self->ut_numbern('resume')
775 || $self->ut_numbern('expire')
776 || $self->ut_numbern('dundate')
777 || $self->ut_flag('no_auto', [ '', 'Y' ])
778 || $self->ut_flag('waive_setup', [ '', 'Y' ])
779 || $self->ut_flag('separate_bill')
780 || $self->ut_textn('agent_pkgid')
781 || $self->ut_enum('recur_show_zero', [ '', 'Y', 'N', ])
782 || $self->ut_enum('setup_show_zero', [ '', 'Y', 'N', ])
783 || $self->ut_foreign_keyn('main_pkgnum', 'cust_pkg', 'pkgnum')
784 || $self->ut_foreign_keyn('pkglinknum', 'part_pkg_link', 'pkglinknum')
785 || $self->ut_foreign_keyn('change_to_pkgnum', 'cust_pkg', 'pkgnum')
787 return $error if $error;
789 return "A package with both start date (future start) and setup date (already started) will never bill"
790 if $self->start_date && $self->setup && ! $upgrade;
792 return "A future unsuspend date can only be set for a package with a suspend date"
793 if $self->resume and !$self->susp and !$self->adjourn;
795 $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
802 Check the pkgpart to make sure it's allowed with the reg_code and/or
803 promo_code of the package (if present) and with the customer's agent.
804 Called from C<insert>, unless we are doing a package change that doesn't
812 # my $error = $self->ut_numbern('pkgpart'); # already done
815 if ( $self->reg_code ) {
817 unless ( grep { $self->pkgpart == $_->pkgpart }
818 map { $_->reg_code_pkg }
819 qsearchs( 'reg_code', { 'code' => $self->reg_code,
820 'agentnum' => $self->cust_main->agentnum })
822 return "Unknown registration code";
825 } elsif ( $self->promo_code ) {
828 qsearchs('part_pkg', {
829 'pkgpart' => $self->pkgpart,
830 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
832 return 'Unknown promotional code' unless $promo_part_pkg;
836 unless ( $disable_agentcheck ) {
838 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
839 return "agent ". $agent->agentnum. ':'. $agent->agent.
840 " can't purchase pkgpart ". $self->pkgpart
841 unless $agent->pkgpart_hashref->{ $self->pkgpart }
842 || $agent->agentnum == $self->part_pkg->agentnum;
845 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
846 return $error if $error;
854 =item cancel [ OPTION => VALUE ... ]
856 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
857 in this package, then cancels the package itself (sets the cancel field to
860 Available options are:
864 =item quiet - can be set true to supress email cancellation notices.
866 =item time - can be set to cancel the package based on a specific future or
867 historical date. Using time ensures that the remaining amount is calculated
868 correctly. Note however that this is an immediate cancel and just changes
869 the date. You are PROBABLY looking to expire the account instead of using
872 =item reason - can be set to a cancellation reason (see L<FS::reason>),
873 either a reasonnum of an existing reason, or passing a hashref will create
874 a new reason. The hashref should have the following keys: typenum - Reason
875 type (see L<FS::reason_type>, reason - Text of the new reason.
877 =item date - can be set to a unix style timestamp to specify when to
880 =item nobill - can be set true to skip billing if it might otherwise be done.
882 =item unused_credit - can be set to 1 to credit the remaining time, or 0 to
883 not credit it. This must be set (by change()) when changing the package
884 to a different pkgpart or location, and probably shouldn't be in any other
885 case. If it's not set, the 'unused_credit_cancel' part_pkg option will
888 =item no_delay_cancel - prevents delay_cancel behavior
889 no matter what other options say, for use when changing packages (or any
890 other time you're really sure you want an immediate cancel)
894 If there is an error, returns the error, otherwise returns false.
898 #NOT DOCUMENTING - this should only be used when calling recursively
899 #=item delay_cancel - for internal use, to allow proper handling of
900 #supplemental packages when the main package is flagged to suspend
901 #before cancelling, probably shouldn't be used otherwise (set the
902 #corresponding package option instead)
905 my( $self, %options ) = @_;
908 # supplemental packages can now be separately canceled, though the UI
909 # shouldn't permit it
911 ## pass all suspend/cancel actions to the main package
912 ## (unless the pkglinknum has been removed, then the link is defunct and
913 ## this package can be canceled on its own)
914 #if ( $self->main_pkgnum and $self->pkglinknum and !$options{'from_main'} ) {
915 # return $self->main_pkg->cancel(%options);
918 my $conf = new FS::Conf;
920 warn "cust_pkg::cancel called with options".
921 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
924 my $oldAutoCommit = $FS::UID::AutoCommit;
925 local $FS::UID::AutoCommit = 0;
928 my $old = $self->select_for_update;
930 if ( $old->get('cancel') || $self->get('cancel') ) {
931 dbh->rollback if $oldAutoCommit;
932 return ""; # no error
935 # XXX possibly set cancel_time to the expire date?
936 my $cancel_time = $options{'time'} || time;
937 my $date = $options{'date'} if $options{'date'}; # expire/cancel later
938 $date = '' if ($date && $date <= $cancel_time); # complain instead?
940 my $delay_cancel = $options{'no_delay_cancel'} ? 0 : $options{'delay_cancel'};
941 if ( !$date && $self->part_pkg->option('delay_cancel',1)
942 && (($self->status eq 'active') || ($self->status eq 'suspended'))
943 && !$options{'no_delay_cancel'}
945 my $expdays = $conf->config('part_pkg-delay_cancel-days') || 1;
946 my $expsecs = 60*60*24*$expdays;
947 my $suspfor = $self->susp ? $cancel_time - $self->susp : 0;
948 $expsecs = $expsecs - $suspfor if $suspfor;
949 unless ($expsecs <= 0) { #if it's already been suspended long enough, don't re-suspend
951 $date = $cancel_time + $expsecs;
955 #race condition: usage could be ongoing until unprovisioned
956 #resolved by performing a change package instead (which unprovisions) and
958 if ( !$options{nobill} && !$date ) {
959 # && $conf->exists('bill_usage_on_cancel') ) { #calc_cancel checks this
960 my $copy = $self->new({$self->hash});
962 $copy->cust_main->bill( 'pkg_list' => [ $copy ],
964 'time' => $cancel_time );
965 warn "Error billing during cancel, custnum ".
966 #$self->cust_main->custnum. ": $error"
971 if ( $options{'reason'} ) {
972 $error = $self->insert_reason( 'reason' => $options{'reason'},
973 'action' => $date ? 'expire' : 'cancel',
974 'date' => $date ? $date : $cancel_time,
975 'reason_otaker' => $options{'reason_otaker'},
978 dbh->rollback if $oldAutoCommit;
979 return "Error inserting cust_pkg_reason: $error";
983 my %svc_cancel_opt = ();
984 $svc_cancel_opt{'date'} = $date if $date;
985 foreach my $cust_svc (
988 sort { $a->[1] <=> $b->[1] }
989 map { [ $_, $_->svc_x ? $_->svc_x->table_info->{'cancel_weight'} : -1 ]; }
990 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
992 my $part_svc = $cust_svc->part_svc;
993 next if ( defined($part_svc) and $part_svc->preserve );
994 my $error = $cust_svc->cancel( %svc_cancel_opt );
997 $dbh->rollback if $oldAutoCommit;
998 return 'Error '. ($svc_cancel_opt{'date'} ? 'expiring' : 'canceling' ).
1003 # if a reasonnum was passed, get the actual reason object so we can check
1007 if ($options{'reason'} =~ /^\d+$/) {
1008 $reason = FS::reason->by_key($options{'reason'});
1012 # credit remaining time if any of these are true:
1013 # - unused_credit => 1 was passed (this happens when canceling a package
1014 # for a package change when unused_credit_change is set)
1015 # - no unused_credit option, and there is a cancel reason, and the cancel
1016 # reason says to credit the package
1017 # - no unused_credit option, and the package definition says to credit the
1018 # package on cancellation
1020 if ( exists($options{'unused_credit'}) ) {
1021 $do_credit = $options{'unused_credit'};
1022 } elsif ( defined($reason) && $reason->unused_credit ) {
1025 $do_credit = $self->part_pkg->option('unused_credit_cancel', 1);
1028 my $error = $self->credit_remaining('cancel', $cancel_time);
1030 $dbh->rollback if $oldAutoCommit;
1036 my %hash = $self->hash;
1038 $hash{'expire'} = $date;
1039 if ($delay_cancel) {
1040 # just to be sure these are clear
1041 $hash{'adjourn'} = undef;
1042 $hash{'resume'} = undef;
1045 $hash{'cancel'} = $cancel_time;
1047 $hash{'change_custnum'} = $options{'change_custnum'};
1049 # if this is a supplemental package that's lost its part_pkg_link, and it's
1050 # being canceled for real, unlink it completely
1051 if ( !$date and ! $self->pkglinknum ) {
1052 $hash{main_pkgnum} = '';
1055 # if there is a future package change scheduled, unlink from it (like
1056 # abort_change) first, then delete it.
1057 $hash{'change_to_pkgnum'} = '';
1059 # save the package state
1060 my $new = new FS::cust_pkg ( \%hash );
1061 $error = $new->replace( $self, options => { $self->options } );
1063 if ( $self->change_to_pkgnum ) {
1064 my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
1065 $error ||= $change_to->cancel('no_delay_cancel' => 1) || $change_to->delete;
1068 $dbh->rollback if $oldAutoCommit;
1072 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1073 $error = $supp_pkg->cancel(%options,
1075 'date' => $date, #in case it got changed by delay_cancel
1076 'delay_cancel' => $delay_cancel,
1079 $dbh->rollback if $oldAutoCommit;
1080 return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
1084 if ($delay_cancel && !$options{'from_main'}) {
1085 $error = $new->suspend(
1087 'time' => $cancel_time
1092 foreach my $usage ( $self->cust_pkg_usage ) {
1093 $error = $usage->delete;
1095 $dbh->rollback if $oldAutoCommit;
1096 return "deleting usage pools: $error";
1101 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1102 return '' if $date; #no errors
1104 my $cust_main = $self->cust_main;
1106 my @invoicing_list = $cust_main->invoicing_list_emailonly;
1107 my $msgnum = $conf->config('cancel_msgnum', $cust_main->agentnum);
1108 if ( !$options{'quiet'}
1109 && $conf->config_bool('emailcancel', $cust_main->agentnum)
1114 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
1115 my $error = $msg_template->send(
1116 'cust_main' => $cust_main,
1119 #should this do something on errors?
1122 my %pkg_class = map { $_=>1 }
1123 $conf->config('cancel_msgnum-referring_cust-pkg_class');
1124 my $ref_msgnum = $conf->config('cancel_msgnum-referring_cust');
1125 if ( !$options{'quiet'}
1126 && $cust_main->referral_custnum
1127 && $pkg_class{ $self->classnum }
1131 my $msg_template = qsearchs('msg_template', { msgnum => $ref_msgnum });
1132 my $error = $msg_template->send(
1133 'cust_main' => $cust_main->referring_cust_main,
1136 #should this do something on errors?
1143 =item cancel_if_expired [ NOW_TIMESTAMP ]
1145 Cancels this package if its expire date has been reached.
1149 sub cancel_if_expired {
1151 my $time = shift || time;
1152 return '' unless $self->expire && $self->expire <= $time;
1153 my $error = $self->cancel;
1155 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
1156 $self->custnum. ": $error";
1161 =item uncancel_svc_x
1163 For cancelled cust_pkg, returns a list of new, uninserted FS::svc_X records
1164 for services that would be inserted by L</uncancel>. Returned objects also
1165 include the field _h_svc_x, which contains the service history object.
1167 Set pkgnum before inserting.
1169 Accepts the following options:
1171 only_svcnum - arrayref of svcnum, only returns objects for these svcnum
1172 (and only if they would otherwise be returned by this)
1176 sub uncancel_svc_x {
1177 my ($self, %opt) = @_;
1179 die 'uncancel_svc_x called on a non-cancelled cust_pkg' unless $self->get('cancel');
1181 #find historical services within this timeframe before the package cancel
1182 # (incompatible with "time" option to cust_pkg->cancel?)
1183 my $fuzz = 2 * 60; #2 minutes? too much? (might catch separate unprovision)
1184 # too little? (unprovisioing export delay?)
1185 my($end, $start) = ( $self->get('cancel'), $self->get('cancel') - $fuzz );
1186 my @h_cust_svc = $self->h_cust_svc( $end, $start );
1189 foreach my $h_cust_svc (@h_cust_svc) {
1190 next if $opt{'only_svcnum'} && !(grep { $_ == $h_cust_svc->svcnum } @{$opt{'only_svcnum'}});
1191 # filter out services that still exist on this package (ie preserved svcs)
1192 # but keep services that have since been provisioned on another package (for informational purposes)
1193 next if qsearchs('cust_svc',{ 'svcnum' => $h_cust_svc->svcnum, 'pkgnum' => $self->pkgnum });
1194 my $h_svc_x = $h_cust_svc->h_svc_x( $end, $start );
1195 next unless $h_svc_x; # this probably doesn't happen, but just in case
1196 (my $table = $h_svc_x->table) =~ s/^h_//;
1197 require "FS/$table.pm";
1198 my $class = "FS::$table";
1199 my $svc_x = $class->new( {
1200 'svcpart' => $h_cust_svc->svcpart,
1201 '_h_svc_x' => $h_svc_x,
1202 map { $_ => $h_svc_x->get($_) } fields($table)
1206 if ( $h_svc_x->isa('FS::h_svc_Radius_Mixin') ) {
1207 $svc_x->usergroup( [ $h_svc_x->h_usergroup($end, $start) ] );
1210 #these are pretty rare, but should handle them
1211 # - dsl_device (mac addresses)
1212 # - phone_device (mac addresses)
1213 # - dsl_note (ikano notes)
1214 # - domain_record (i.e. restore DNS information w/domains)
1215 # - inventory_item(?) (inventory w/un-cancelling service?)
1216 # - nas (svc_broaband nas stuff)
1217 #this stuff is unused in the wild afaik
1218 # - mailinglistmember
1220 # - svc_domain.parent_svcnum?
1221 # - acct_snarf (ancient mail fetching config)
1222 # - cgp_rule (communigate)
1223 # - cust_svc_option (used by our Tron stuff)
1224 # - acct_rt_transaction (used by our time worked stuff)
1226 push @svc_x, $svc_x;
1231 =item uncancel_svc_summary
1233 Returns an array of hashrefs, one for each service that could
1234 potentially be reprovisioned by L</uncancel>, with the following keys:
1242 label - from history table if not currently calculable, undefined if it can't be loaded
1244 reprovisionable - 1 if test reprovision succeeded, otherwise 0
1246 num_cust_svc - number of svcs for this svcpart, only if summarizing (see below)
1248 Cannot be run from within a transaction. Performs inserts
1249 to test the results, and then rolls back the transaction.
1250 Does not perform exports, so does not catch if export would fail.
1252 Also accepts the following options:
1254 no_test_reprovision - skip the test inserts (reprovisionable field will not exist)
1256 summarize_size - if true, returns a single summary record for svcparts with at
1257 least this many svcs, will have key num_cust_svc but not uncancel_svcnum, label or reprovisionable
1261 sub uncancel_svc_summary {
1262 my ($self, %opt) = @_;
1264 die 'uncancel_svc_summary called on a non-cancelled cust_pkg' unless $self->get('cancel');
1265 die 'uncancel_svc_summary called from within a transaction' unless $FS::UID::AutoCommit;
1267 local $FS::svc_Common::noexport_hack = 1; # very important not to run exports!!!
1268 local $FS::UID::AutoCommit = 0;
1270 # sort by svcpart, to check summarize_size
1271 my $uncancel_svc_x = {};
1272 foreach my $svc_x (sort { $a->{'svcpart'} <=> $b->{'svcpart'} } $self->uncancel_svc_x) {
1273 $uncancel_svc_x->{$svc_x->svcpart} = [] unless $uncancel_svc_x->{$svc_x->svcpart};
1274 push @{$uncancel_svc_x->{$svc_x->svcpart}}, $svc_x;
1278 foreach my $svcpart (keys %$uncancel_svc_x) {
1279 my @svcpart_svc_x = @{$uncancel_svc_x->{$svcpart}};
1280 if ($opt{'summarize_size'} && (@svcpart_svc_x >= $opt{'summarize_size'})) {
1281 my $svc_x = $svcpart_svc_x[0]; #grab first one for access to $part_svc
1282 my $part_svc = $svc_x->part_svc;
1284 'svcpart' => $part_svc->svcpart,
1285 'svc' => $part_svc->svc,
1286 'num_cust_svc' => scalar(@svcpart_svc_x),
1289 foreach my $svc_x (@svcpart_svc_x) {
1290 my $part_svc = $svc_x->part_svc;
1292 'svcpart' => $part_svc->svcpart,
1293 'svc' => $part_svc->svc,
1294 'uncancel_svcnum' => $svc_x->get('_h_svc_x')->svcnum,
1296 $svc_x->pkgnum($self->pkgnum); # provisioning services on a canceled package, will be rolled back
1298 unless ($opt{'no_test_reprovision'}) {
1299 # avoid possibly fatal errors from missing linked records
1300 eval { $insert_error = $svc_x->insert };
1301 $insert_error ||= $@;
1303 if ($opt{'no_test_reprovision'} or $insert_error) {
1304 # avoid possibly fatal errors from missing linked records
1305 eval { $out->{'label'} = $svc_x->label };
1306 eval { $out->{'label'} = $svc_x->get('_h_svc_x')->label } unless defined($out->{'label'});
1307 $out->{'reprovisionable'} = 0 unless $opt{'no_test_reprovision'};
1309 $out->{'label'} = $svc_x->label;
1310 $out->{'reprovisionable'} = 1;
1323 "Un-cancels" this package: Orders a new package with the same custnum, pkgpart,
1324 locationnum, (other fields?). Attempts to re-provision cancelled services
1325 using history information (errors at this stage are not fatal).
1327 cust_pkg: pass a scalar reference, will be filled in with the new cust_pkg object
1329 svc_fatal: service provisioning errors are fatal
1331 svc_errors: pass an array reference, will be filled in with any provisioning errors
1333 only_svcnum: arrayref, only attempt to re-provision these cancelled services
1335 main_pkgnum: link the package as a supplemental package of this one. For
1341 my( $self, %options ) = @_;
1343 #in case you try do do $uncancel-date = $cust_pkg->uncacel
1344 return '' unless $self->get('cancel');
1346 if ( $self->main_pkgnum and !$options{'main_pkgnum'} ) {
1347 return $self->main_pkg->uncancel(%options);
1354 my $oldAutoCommit = $FS::UID::AutoCommit;
1355 local $FS::UID::AutoCommit = 0;
1359 # insert the new package
1362 my $cust_pkg = new FS::cust_pkg {
1363 last_bill => ( $options{'last_bill'} || $self->get('last_bill') ),
1364 bill => ( $options{'bill'} || $self->get('bill') ),
1366 uncancel_pkgnum => $self->pkgnum,
1367 main_pkgnum => ($options{'main_pkgnum'} || ''),
1368 map { $_ => $self->get($_) } qw(
1369 custnum pkgpart locationnum
1371 susp adjourn resume expire start_date contract_end dundate
1372 change_date change_pkgpart change_locationnum
1373 no_auto separate_bill quantity agent_pkgid
1374 recur_show_zero setup_show_zero
1378 my $error = $cust_pkg->insert(
1379 'change' => 1, #supresses any referral credit to a referring customer
1380 'allow_pkgpart' => 1, # allow this even if the package def is disabled
1383 $dbh->rollback if $oldAutoCommit;
1392 foreach my $svc_x ($self->uncancel_svc_x('only_svcnum' => $options{'only_svcnum'})) {
1394 $svc_x->pkgnum($cust_pkg->pkgnum);
1395 my $svc_error = $svc_x->insert;
1398 if ( $options{svc_fatal} ) {
1399 $dbh->rollback if $oldAutoCommit;
1402 # if we've failed to insert the svc_x object, svc_Common->insert
1403 # will have removed the cust_svc already. if not, then both records
1404 # were inserted but we failed for some other reason (export, most
1405 # likely). in that case, report the error and delete the records.
1406 push @svc_errors, $svc_error;
1407 my $cust_svc = qsearchs('cust_svc', { 'svcnum' => $svc_x->svcnum });
1409 # except if export_insert failed, export_delete probably won't be
1411 local $FS::svc_Common::noexport_hack = 1;
1412 my $cleanup_error = $svc_x->delete; # also deletes cust_svc
1413 if ( $cleanup_error ) { # and if THAT fails, then run away
1414 $dbh->rollback if $oldAutoCommit;
1415 return $cleanup_error;
1420 } #foreach uncancel_svc_x
1423 # also move over any services that didn't unprovision at cancellation
1426 foreach my $cust_svc ( qsearch('cust_svc', { pkgnum => $self->pkgnum } ) ) {
1427 $cust_svc->pkgnum( $cust_pkg->pkgnum );
1428 my $error = $cust_svc->replace;
1430 $dbh->rollback if $oldAutoCommit;
1436 # Uncancel any supplemental packages, and make them supplemental to the
1440 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1442 $error = $supp_pkg->uncancel(%options, 'main_pkgnum' => $cust_pkg->pkgnum);
1444 $dbh->rollback if $oldAutoCommit;
1445 return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
1453 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1455 ${ $options{cust_pkg} } = $cust_pkg if ref($options{cust_pkg});
1456 @{ $options{svc_errors} } = @svc_errors if ref($options{svc_errors});
1463 Cancels any pending expiration (sets the expire field to null)
1464 for this package and any supplemental packages.
1466 If there is an error, returns the error, otherwise returns false.
1474 my $oldAutoCommit = $FS::UID::AutoCommit;
1475 local $FS::UID::AutoCommit = 0;
1478 my $old = $self->select_for_update;
1480 my $pkgnum = $old->pkgnum;
1481 if ( $old->get('cancel') || $self->get('cancel') ) {
1482 dbh->rollback if $oldAutoCommit;
1483 return "Can't unexpire cancelled package $pkgnum";
1484 # or at least it's pointless
1487 unless ( $old->get('expire') && $self->get('expire') ) {
1488 dbh->rollback if $oldAutoCommit;
1489 return ""; # no error
1492 my %hash = $self->hash;
1493 $hash{'expire'} = '';
1494 my $new = new FS::cust_pkg ( \%hash );
1495 $error = $new->replace( $self, options => { $self->options } );
1497 $dbh->rollback if $oldAutoCommit;
1501 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1502 $error = $supp_pkg->unexpire;
1504 $dbh->rollback if $oldAutoCommit;
1505 return "unexpiring supplemental pkg#".$supp_pkg->pkgnum.": $error";
1509 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1515 =item suspend [ OPTION => VALUE ... ]
1517 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1518 package, then suspends the package itself (sets the susp field to now).
1520 Available options are:
1524 =item reason - can be set to a cancellation reason (see L<FS::reason>),
1525 either a reasonnum of an existing reason, or passing a hashref will create
1526 a new reason. The hashref should have the following keys:
1527 - typenum - Reason type (see L<FS::reason_type>
1528 - reason - Text of the new reason.
1530 =item date - can be set to a unix style timestamp to specify when to
1533 =item time - can be set to override the current time, for calculation
1534 of final invoices or unused-time credits
1536 =item resume_date - can be set to a time when the package should be
1537 unsuspended. This may be more convenient than calling C<unsuspend()>
1540 =item from_main - allows a supplemental package to be suspended, rather
1541 than redirecting the method call to its main package. For internal use.
1543 =item from_cancel - used when suspending from the cancel method, forces
1544 this to skip everything besides basic suspension. For internal use.
1548 If there is an error, returns the error, otherwise returns false.
1553 my( $self, %options ) = @_;
1556 # supplemental packages still can't be separately suspended, but silently
1557 # exit instead of failing or passing the action to the main package (so
1558 # that the "Suspend customer" action doesn't trip over the supplemental
1561 if ( $self->main_pkgnum and !$options{'from_main'} ) {
1565 my $oldAutoCommit = $FS::UID::AutoCommit;
1566 local $FS::UID::AutoCommit = 0;
1569 my $old = $self->select_for_update;
1571 my $pkgnum = $old->pkgnum;
1572 if ( $old->get('cancel') || $self->get('cancel') ) {
1573 dbh->rollback if $oldAutoCommit;
1574 return "Can't suspend cancelled package $pkgnum";
1577 if ( $old->get('susp') || $self->get('susp') ) {
1578 dbh->rollback if $oldAutoCommit;
1579 return ""; # no error # complain on adjourn?
1582 my $suspend_time = $options{'time'} || time;
1583 my $date = $options{date} if $options{date}; # adjourn/suspend later
1584 $date = '' if ($date && $date <= $suspend_time); # complain instead?
1586 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
1587 dbh->rollback if $oldAutoCommit;
1588 return "Package $pkgnum expires before it would be suspended.";
1591 # some false laziness with sub cancel
1592 if ( !$options{nobill} && !$date && !$options{'from_cancel'} &&
1593 $self->part_pkg->option('bill_suspend_as_cancel',1) ) {
1594 # kind of a kludge--'bill_suspend_as_cancel' to avoid having to
1595 # make the entire cust_main->bill path recognize 'suspend' and
1596 # 'cancel' separately.
1597 warn "Billing $pkgnum on suspension (at $suspend_time)\n" if $DEBUG;
1598 my $copy = $self->new({$self->hash});
1600 $copy->cust_main->bill( 'pkg_list' => [ $copy ],
1602 'time' => $suspend_time );
1603 warn "Error billing during suspend, custnum ".
1604 #$self->cust_main->custnum. ": $error"
1609 my $cust_pkg_reason;
1610 if ( $options{'reason'} ) {
1611 $error = $self->insert_reason( 'reason' => $options{'reason'},
1612 'action' => $date ? 'adjourn' : 'suspend',
1613 'date' => $date ? $date : $suspend_time,
1614 'reason_otaker' => $options{'reason_otaker'},
1617 dbh->rollback if $oldAutoCommit;
1618 return "Error inserting cust_pkg_reason: $error";
1620 $cust_pkg_reason = qsearchs('cust_pkg_reason', {
1621 'date' => $date ? $date : $suspend_time,
1622 'action' => $date ? 'A' : 'S',
1623 'pkgnum' => $self->pkgnum,
1627 # if a reasonnum was passed, get the actual reason object so we can check
1629 # (passing a reason hashref is still allowed, but it can't be used with
1630 # the fancy behavioral options.)
1633 if ($options{'reason'} =~ /^\d+$/) {
1634 $reason = FS::reason->by_key($options{'reason'});
1637 my %hash = $self->hash;
1639 $hash{'adjourn'} = $date;
1641 $hash{'susp'} = $suspend_time;
1644 my $resume_date = $options{'resume_date'} || 0;
1645 if ( $resume_date > ($date || $suspend_time) ) {
1646 $hash{'resume'} = $resume_date;
1649 $options{options} ||= {};
1651 my $new = new FS::cust_pkg ( \%hash );
1652 $error = $new->replace( $self, options => { $self->options,
1653 %{ $options{options} },
1657 $dbh->rollback if $oldAutoCommit;
1661 unless ( $date ) { # then we are suspending now
1663 unless ($options{'from_cancel'}) {
1664 # credit remaining time if appropriate
1665 # (if required by the package def, or the suspend reason)
1666 my $unused_credit = $self->part_pkg->option('unused_credit_suspend',1)
1667 || ( defined($reason) && $reason->unused_credit );
1669 if ( $unused_credit ) {
1670 warn "crediting unused time on pkg#".$self->pkgnum."\n" if $DEBUG;
1671 my $error = $self->credit_remaining('suspend', $suspend_time);
1673 $dbh->rollback if $oldAutoCommit;
1679 my @cust_svc = qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } );
1681 #attempt ordering ala cust_svc_suspend_cascade (without infinite-looping
1682 # on the circular dep case)
1683 # (this is too simple for multi-level deps, we need to use something
1684 # to resolve the DAG properly when possible)
1686 $svcpart{$_->svcpart} = 0 foreach @cust_svc;
1687 foreach my $svcpart ( keys %svcpart ) {
1688 foreach my $part_svc_link (
1689 FS::part_svc_link->by_agentnum($self->cust_main->agentnum,
1690 src_svcpart => $svcpart,
1691 link_type => 'cust_svc_suspend_cascade'
1694 $svcpart{$part_svc_link->dst_svcpart} = max(
1695 $svcpart{$part_svc_link->dst_svcpart},
1696 $svcpart{$part_svc_link->src_svcpart} + 1
1700 @cust_svc = sort { $svcpart{ $a->svcpart } <=> $svcpart{ $b->svcpart } }
1704 foreach my $cust_svc ( @cust_svc ) {
1705 $cust_svc->suspend( 'labels_arrayref' => \@labels );
1708 # suspension fees: if there is a feepart, and it's not an unsuspend fee,
1709 # and this is not a suspend-before-cancel
1710 if ( $cust_pkg_reason ) {
1711 my $reason_obj = $cust_pkg_reason->reason;
1712 if ( $reason_obj->feepart and
1713 ! $reason_obj->fee_on_unsuspend and
1714 ! $options{'from_cancel'} ) {
1716 # register the need to charge a fee, cust_main->bill will do the rest
1717 warn "registering suspend fee: pkgnum ".$self->pkgnum.", feepart ".$reason->feepart."\n"
1719 my $cust_pkg_reason_fee = FS::cust_pkg_reason_fee->new({
1720 'pkgreasonnum' => $cust_pkg_reason->num,
1721 'pkgnum' => $self->pkgnum,
1722 'feepart' => $reason->feepart,
1723 'nextbill' => $reason->fee_hold,
1725 $error ||= $cust_pkg_reason_fee->insert;
1729 my $conf = new FS::Conf;
1730 if ( $conf->config('suspend_email_admin') && !$options{'from_cancel'} ) {
1732 my $error = send_email(
1733 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1734 #invoice_from ??? well as good as any
1735 'to' => $conf->config('suspend_email_admin'),
1736 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
1738 "This is an automatic message from your Freeside installation\n",
1739 "informing you that the following customer package has been suspended:\n",
1741 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1742 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1743 ( map { "Service : $_\n" } @labels ),
1745 'custnum' => $self->custnum,
1746 'msgtype' => 'admin'
1750 warn "WARNING: can't send suspension admin email (suspending anyway): ".
1758 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1759 $error = $supp_pkg->suspend(%options, 'from_main' => 1);
1761 $dbh->rollback if $oldAutoCommit;
1762 return "suspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1766 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1771 =item credit_remaining MODE TIME
1773 Generate a credit for this package for the time remaining in the current
1774 billing period. MODE is either "suspend" or "cancel" (determines the
1775 credit type). TIME is the time of suspension/cancellation. Both arguments
1780 # Implementation note:
1782 # If you pkgpart-change a package that has been billed, and it's set to give
1783 # credit on package change, then this method gets called and then the new
1784 # package will have no last_bill date. Therefore the customer will be credited
1785 # only once (per billing period) even if there are multiple package changes.
1787 # If you location-change a package that has been billed, this method will NOT
1788 # be called and the new package WILL have the last bill date of the old
1791 # If the new package is then canceled within the same billing cycle,
1792 # credit_remaining needs to run calc_remain on the OLD package to determine
1793 # the amount of unused time to credit.
1795 sub credit_remaining {
1796 # Add a credit for remaining service
1797 my ($self, $mode, $time) = @_;
1798 die 'credit_remaining requires suspend or cancel'
1799 unless $mode eq 'suspend' or $mode eq 'cancel';
1800 die 'no suspend/cancel time' unless $time > 0;
1802 my $conf = FS::Conf->new;
1803 my $reason_type = $conf->config($mode.'_credit_type');
1807 my $remain_pkg = $self;
1808 my (@billpkgnums, @amounts, @setuprecurs);
1810 # we may have to walk back past some package changes to get to the
1811 # one that actually has unused time. loop until that happens, or we
1812 # reach the first package in the chain.
1814 my $last_bill = $remain_pkg->get('last_bill') || 0;
1815 my $next_bill = $remain_pkg->get('bill') || 0;
1816 if ( $last_bill > 0 # the package has been billed
1817 and $next_bill > 0 # the package has a next bill date
1818 and $next_bill >= $time # which is in the future
1821 # Find actual charges for the period ending on or after the cancel
1823 my @charges = qsearch('cust_bill_pkg', {
1824 pkgnum => $remain_pkg->pkgnum,
1825 edate => {op => '>=', value => $time},
1826 recur => {op => '>' , value => 0},
1829 foreach my $cust_bill_pkg (@charges) {
1830 # hack to deal with the weird behavior of edate on package
1832 my $edate = $cust_bill_pkg->edate;
1833 if ( $self->recur_temporality eq 'preceding' ) {
1834 $edate = $self->add_freq($cust_bill_pkg->sdate);
1837 # this will also get any package charges that are _entirely_ after
1838 # the cancellation date (can happen with advance billing). in that
1839 # case, use the entire recurring charge:
1840 my $amount = $cust_bill_pkg->recur - $cust_bill_pkg->usage;
1841 my $max_credit = $amount
1842 - $cust_bill_pkg->credited('', '', setuprecur => 'recur') || 0;
1844 # but if the cancellation happens during the interval, prorate it:
1845 # (XXX obey prorate_round_day here?)
1846 if ( $cust_bill_pkg->sdate < $time ) {
1848 ($edate - $time) / ($edate - $cust_bill_pkg->sdate);
1851 # if there are existing credits, don't let the sum of credits exceed
1852 # the recurring charge
1853 $amount = $max_credit if $amount > $max_credit;
1855 $amount = sprintf('%.2f', $amount);
1857 # if no time has been used and/or there are existing line item
1858 # credits, we may end up not needing to credit anything.
1859 if ( $amount > 0 ) {
1861 push @billpkgnums, $cust_bill_pkg->billpkgnum;
1862 push @amounts, $amount;
1863 push @setuprecurs, 'recur';
1865 warn "Crediting for $amount on package ".$remain_pkg->pkgnum."\n"
1874 if ( my $changed_from_pkgnum = $remain_pkg->change_pkgnum ) {
1875 $remain_pkg = FS::cust_pkg->by_key($changed_from_pkgnum);
1877 # the package has really never been billed
1882 # keep traditional behavior here.
1884 my $reason = FS::reason->new_or_existing(
1885 reason => 'Credit for unused time on '. $self->part_pkg->pkg,
1886 type => $reason_type,
1890 return "failed to set credit reason: $@";
1893 my $error = FS::cust_credit->credit_lineitems(
1894 'billpkgnums' => \@billpkgnums,
1895 'setuprecurs' => \@setuprecurs,
1896 'amounts' => \@amounts,
1897 'custnum' => $self->custnum,
1899 'reasonnum' => $reason->reasonnum,
1907 =item unsuspend [ OPTION => VALUE ... ]
1909 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1910 package, then unsuspends the package itself (clears the susp field and the
1911 adjourn field if it is in the past). If the suspend reason includes an
1912 unsuspension package, that package will be ordered.
1914 Available options are:
1920 Can be set to a date to unsuspend the package in the future (the 'resume'
1923 =item adjust_next_bill
1925 Can be set true to adjust the next bill date forward by
1926 the amount of time the account was inactive. This was set true by default
1927 in the past (from 1.4.2 and 1.5.0pre6 through 1.7.0), but now needs to be
1928 explicitly requested with this option or in the price plan.
1932 If there is an error, returns the error, otherwise returns false.
1937 my( $self, %opt ) = @_;
1940 # pass all suspend/cancel actions to the main package
1941 if ( $self->main_pkgnum and !$opt{'from_main'} ) {
1942 return $self->main_pkg->unsuspend(%opt);
1945 my $oldAutoCommit = $FS::UID::AutoCommit;
1946 local $FS::UID::AutoCommit = 0;
1949 my $old = $self->select_for_update;
1951 my $pkgnum = $old->pkgnum;
1952 if ( $old->get('cancel') || $self->get('cancel') ) {
1953 $dbh->rollback if $oldAutoCommit;
1954 return "Can't unsuspend cancelled package $pkgnum";
1957 unless ( $old->get('susp') && $self->get('susp') ) {
1958 $dbh->rollback if $oldAutoCommit;
1959 return ""; # no error # complain instead?
1962 # handle the case of setting a future unsuspend (resume) date
1963 # and do not continue to actually unsuspend the package
1964 my $date = $opt{'date'};
1965 if ( $date and $date > time ) { # return an error if $date <= time?
1967 if ( $old->get('expire') && $old->get('expire') < $date ) {
1968 $dbh->rollback if $oldAutoCommit;
1969 return "Package $pkgnum expires before it would be unsuspended.";
1972 my $new = new FS::cust_pkg { $self->hash };
1973 $new->set('resume', $date);
1974 $error = $new->replace($self, options => $self->options);
1977 $dbh->rollback if $oldAutoCommit;
1981 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1987 if (!$self->setup) {
1988 # then this package is being released from on-hold status
1989 $error = $self->set_initial_timers;
1991 $dbh->rollback if $oldAutoCommit;
1998 foreach my $cust_svc (
1999 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
2001 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
2003 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
2004 $dbh->rollback if $oldAutoCommit;
2005 return "Illegal svcdb value in part_svc!";
2008 require "FS/$svcdb.pm";
2010 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
2012 $error = $svc->unsuspend;
2014 $dbh->rollback if $oldAutoCommit;
2017 my( $label, $value ) = $cust_svc->label;
2018 push @labels, "$label: $value";
2023 my $cust_pkg_reason = $self->last_cust_pkg_reason('susp');
2024 my $reason = $cust_pkg_reason ? $cust_pkg_reason->reason : '';
2026 my %hash = $self->hash;
2027 my $inactive = time - $hash{'susp'};
2029 my $conf = new FS::Conf;
2031 #adjust the next bill date forward
2032 # increment next bill date if certain conditions are met:
2033 # - it was due to be billed at some point
2034 # - either the global or local config says to do this
2035 my $adjust_bill = 0;
2038 && ( $hash{'bill'} || $hash{'setup'} )
2039 && ( $opt{'adjust_next_bill'}
2040 || $conf->exists('unsuspend-always_adjust_next_bill_date')
2041 || $self->part_pkg->option('unsuspend_adjust_bill', 1)
2048 # - the package billed during suspension
2049 # - or it was ordered on hold
2050 # - or the customer was credited for the unused time
2052 if ( $self->option('suspend_bill',1)
2053 or ( $self->part_pkg->option('suspend_bill',1)
2054 and ! $self->option('no_suspend_bill',1)
2056 or $hash{'order_date'} == $hash{'susp'}
2061 if ( $adjust_bill ) {
2062 if ( $self->part_pkg->option('unused_credit_suspend')
2063 or ( ref($reason) and $reason->unused_credit ) ) {
2064 # then the customer was credited for the unused time before suspending,
2065 # so their next bill should be immediate
2066 $hash{'bill'} = time;
2068 # add the length of time suspended to the bill date
2069 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
2074 $hash{'adjourn'} = '' if $hash{'adjourn'} and $hash{'adjourn'} < time;
2075 $hash{'resume'} = '' if !$hash{'adjourn'};
2076 my $new = new FS::cust_pkg ( \%hash );
2077 $error = $new->replace( $self, options => { $self->options } );
2079 $dbh->rollback if $oldAutoCommit;
2086 if ( $reason->unsuspend_pkgpart ) {
2087 warn "Suspend reason '".$reason->reason."' uses deprecated unsuspend_pkgpart feature.\n";
2088 my $part_pkg = FS::part_pkg->by_key($reason->unsuspend_pkgpart)
2089 or $error = "Unsuspend package definition ".$reason->unsuspend_pkgpart.
2091 my $start_date = $self->cust_main->next_bill_date
2092 if $reason->unsuspend_hold;
2095 $unsusp_pkg = FS::cust_pkg->new({
2096 'custnum' => $self->custnum,
2097 'pkgpart' => $reason->unsuspend_pkgpart,
2098 'start_date' => $start_date,
2099 'locationnum' => $self->locationnum,
2100 # discount? probably not...
2103 $error ||= $self->cust_main->order_pkg( 'cust_pkg' => $unsusp_pkg );
2106 # new way, using fees
2107 if ( $reason->feepart and $reason->fee_on_unsuspend ) {
2108 # register the need to charge a fee, cust_main->bill will do the rest
2109 warn "registering unsuspend fee: pkgnum ".$self->pkgnum.", feepart ".$reason->feepart."\n"
2111 my $cust_pkg_reason_fee = FS::cust_pkg_reason_fee->new({
2112 'pkgreasonnum' => $cust_pkg_reason->num,
2113 'pkgnum' => $self->pkgnum,
2114 'feepart' => $reason->feepart,
2115 'nextbill' => $reason->fee_hold,
2117 $error ||= $cust_pkg_reason_fee->insert;
2121 $dbh->rollback if $oldAutoCommit;
2126 if ( $conf->config('unsuspend_email_admin') ) {
2128 my $error = send_email(
2129 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
2130 #invoice_from ??? well as good as any
2131 'to' => $conf->config('unsuspend_email_admin'),
2132 'subject' => 'FREESIDE NOTIFICATION: Customer package unsuspended', 'body' => [
2133 "This is an automatic message from your Freeside installation\n",
2134 "informing you that the following customer package has been unsuspended:\n",
2136 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
2137 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
2138 ( map { "Service : $_\n" } @labels ),
2140 "An unsuspension fee was charged: ".
2141 $unsusp_pkg->part_pkg->pkg_comment."\n"
2145 'custnum' => $self->custnum,
2146 'msgtype' => 'admin',
2150 warn "WARNING: can't send unsuspension admin email (unsuspending anyway): ".
2156 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
2157 $error = $supp_pkg->unsuspend(%opt, 'from_main' => 1);
2159 $dbh->rollback if $oldAutoCommit;
2160 return "unsuspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
2164 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2171 Cancels any pending suspension (sets the adjourn field to null)
2172 for this package and any supplemental packages.
2174 If there is an error, returns the error, otherwise returns false.
2182 my $oldAutoCommit = $FS::UID::AutoCommit;
2183 local $FS::UID::AutoCommit = 0;
2186 my $old = $self->select_for_update;
2188 my $pkgnum = $old->pkgnum;
2189 if ( $old->get('cancel') || $self->get('cancel') ) {
2190 dbh->rollback if $oldAutoCommit;
2191 return "Can't unadjourn cancelled package $pkgnum";
2192 # or at least it's pointless
2195 if ( $old->get('susp') || $self->get('susp') ) {
2196 dbh->rollback if $oldAutoCommit;
2197 return "Can't unadjourn suspended package $pkgnum";
2198 # perhaps this is arbitrary
2201 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
2202 dbh->rollback if $oldAutoCommit;
2203 return ""; # no error
2206 my %hash = $self->hash;
2207 $hash{'adjourn'} = '';
2208 $hash{'resume'} = '';
2209 my $new = new FS::cust_pkg ( \%hash );
2210 $error = $new->replace( $self, options => { $self->options } );
2212 $dbh->rollback if $oldAutoCommit;
2216 foreach my $supp_pkg ( $self->supplemental_pkgs ) {
2217 $error = $supp_pkg->unadjourn;
2219 $dbh->rollback if $oldAutoCommit;
2220 return "unadjourning supplemental pkg#".$supp_pkg->pkgnum.": $error";
2224 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2231 =item change HASHREF | OPTION => VALUE ...
2233 Changes this package: cancels it and creates a new one, with a different
2234 pkgpart or locationnum or both. All services are transferred to the new
2235 package (no change will be made if this is not possible).
2237 Options may be passed as a list of key/value pairs or as a hash reference.
2244 New locationnum, to change the location for this package.
2248 New FS::cust_location object, to create a new location and assign it
2253 New FS::cust_main object, to create a new customer and assign the new package
2258 New pkgpart (see L<FS::part_pkg>).
2262 New refnum (see L<FS::part_referral>).
2266 New quantity; if unspecified, the new package will have the same quantity
2271 "New" (existing) FS::cust_pkg object. The package's services and other
2272 attributes will be transferred to this package.
2276 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
2277 susp, adjourn, cancel, expire, and contract_end) to the new package.
2279 =item unprotect_svcs
2281 Normally, change() will rollback and return an error if some services
2282 can't be transferred (also see the I<cust_pkg-change_svcpart> config option).
2283 If unprotect_svcs is true, this method will transfer as many services as
2284 it can and then unconditionally cancel the old package.
2288 If specified, sets this value for the contract_end date on the new package
2289 (without regard for keep_dates or the usual date-preservation behavior.)
2290 Will throw an error if defined but false; the UI doesn't allow editing
2291 this unless it already exists, making removal impossible to undo.
2295 At least one of locationnum, cust_location, pkgpart, refnum, cust_main, or
2296 cust_pkg must be specified (otherwise, what's the point?)
2298 Returns either the new FS::cust_pkg object or a scalar error.
2302 my $err_or_new_cust_pkg = $old_cust_pkg->change
2306 #used by change and change_later
2307 #didn't put with documented check methods because it depends on change-specific opts
2308 #and it also possibly edits the value of opts
2312 if ( defined($opt->{'contract_end'}) ) {
2313 my $current_contract_end = $self->get('contract_end');
2314 unless ($opt->{'contract_end'}) {
2315 if ($current_contract_end) {
2316 return "Cannot remove contract end date when changing packages";
2318 #shouldn't even pass this option if there's not a current value
2319 #but can be handled gracefully if the option is empty
2320 warn "Contract end date passed unexpectedly";
2321 delete $opt->{'contract_end'};
2325 unless ($current_contract_end) {
2326 #option shouldn't be passed, throw error if it's non-empty
2327 return "Cannot add contract end date when changing packages " . $self->pkgnum;
2333 #some false laziness w/order
2336 my $opt = ref($_[0]) ? shift : { @_ };
2338 my $conf = new FS::Conf;
2340 # handle contract_end on cust_pkg same as passed option
2341 if ( $opt->{'cust_pkg'} ) {
2342 $opt->{'contract_end'} = $opt->{'cust_pkg'}->contract_end;
2343 delete $opt->{'contract_end'} unless $opt->{'contract_end'};
2346 # check contract_end, prevent adding/removing
2347 my $error = $self->_check_change($opt);
2348 return $error if $error;
2350 # Transactionize this whole mess
2351 my $oldAutoCommit = $FS::UID::AutoCommit;
2352 local $FS::UID::AutoCommit = 0;
2355 if ( $opt->{'cust_location'} ) {
2356 $error = $opt->{'cust_location'}->find_or_insert;
2358 $dbh->rollback if $oldAutoCommit;
2359 return "creating location record: $error";
2361 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
2364 # figure out if we're changing pkgpart
2365 if ( $opt->{'cust_pkg'} ) {
2366 $opt->{'pkgpart'} = $opt->{'cust_pkg'}->pkgpart;
2369 # whether to override pkgpart checking on the new package
2370 my $same_pkgpart = 1;
2371 if ( $opt->{'pkgpart'} and ( $opt->{'pkgpart'} != $self->pkgpart ) ) {
2376 # When a new discount level is specified in $opt:
2377 # If new discountnum matches old discountnum, months_used/end_date are
2378 # carried over as the discount is applied to the new cust_pkg
2381 # Unless discount-related fields have been set within $opt, change()
2382 # sets no discounts on the changed packages unless the new pkgpart is the
2383 # same as the old pkgpart. In that case, discounts from the old cust_pkg
2384 # are copied onto the new cust_pkg
2386 # Read discount fields from $opt
2387 my %new_discount = $self->_parse_new_discounts($opt);
2388 $self->set(waive_setup => $opt->{waive_setup} ? $opt->{waive_setup} : '');
2390 # Before going any further here: if the package is still in the pre-setup
2391 # state, it's safe to modify it in place. No need to charge/credit for
2392 # partial period, transfer usage pools, copy invoice details, or change any
2393 # dates. We DO need to "transfer" services (from the package to itself) to
2394 # check their validity on the new pkgpart.
2395 if ( ! $self->setup and ! $opt->{cust_pkg} and ! $opt->{cust_main} ) {
2396 foreach ( qw( locationnum pkgpart quantity refnum salesnum waive_setup ) ) {
2397 if ( length($opt->{$_}) ) {
2398 $self->set($_, $opt->{$_});
2401 # almost. if the new pkgpart specifies start/adjourn/expire timers,
2403 if ( !$same_pkgpart ) {
2404 $error ||= $self->set_initial_timers;
2406 # but if contract_end was explicitly specified, that overrides all else
2407 $self->set('contract_end', $opt->{'contract_end'})
2408 if $opt->{'contract_end'};
2410 $error ||= $self->replace;
2412 $dbh->rollback if $oldAutoCommit;
2413 return "modifying package: $error";
2416 # check/convert services (only on pkgpart change, to avoid surprises
2417 # when editing locations)
2418 # (maybe do this if changing quantity?)
2419 if ( !$same_pkgpart ) {
2421 $error = $self->transfer($self);
2423 if ( $error and $error == 0 ) {
2424 $error = "transferring $error";
2425 } elsif ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2426 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2427 $error = $self->transfer($self, 'change_svcpart'=>1 );
2428 if ($error and $error == 0) {
2429 $error = "converting $error";
2434 $error = "unable to transfer all services";
2438 $dbh->rollback if $oldAutoCommit;
2442 } # done transferring services
2444 # Set waive_setup as directed
2445 if ( !$error && exists $opt->{waive_setup} ) {
2446 $self->set(waive_setup => $opt->{waive_setup});
2447 $error = $self->replace;
2450 # Set discounts if explicitly specified in $opt
2451 if ( !$error && %new_discount ) {
2452 $error = $self->change_discount(%new_discount);
2456 $dbh->rollback if $oldAutoCommit;
2460 $dbh->commit if $oldAutoCommit;
2469 $hash{'setup'} = $time if $self->get('setup');
2471 $hash{'change_date'} = $time;
2472 $hash{"change_$_"} = $self->$_()
2473 foreach qw( pkgnum pkgpart locationnum );
2475 my $unused_credit = 0;
2476 my $keep_dates = $opt->{'keep_dates'};
2478 # Special case. If the pkgpart is changing, and the customer is going to be
2479 # credited for remaining time, don't keep setup, bill, or last_bill dates,
2480 # and DO pass the flag to cancel() to credit the customer. If the old
2481 # package had a setup date, set the new package's setup to the package
2482 # change date so that it has the same status as before.
2483 if ( $opt->{'pkgpart'}
2484 and $opt->{'pkgpart'} != $self->pkgpart
2485 and $self->part_pkg->option('unused_credit_change', 1) ) {
2488 $hash{'last_bill'} = '';
2491 # Optionally, carry over the next bill date from the changed cust_pkg
2492 # so an invoice isn't generated until the customer's usual billing date
2493 if ( $self->part_pkg->option('prorate_defer_change_bill', 1) ) {
2494 $hash{bill} = $self->bill;
2498 if ( $keep_dates ) {
2499 foreach my $date ( qw(setup bill last_bill) ) {
2500 $hash{$date} = $self->getfield($date);
2503 # always keep the following dates
2504 foreach my $date (qw(order_date susp adjourn cancel expire resume
2505 start_date contract_end)) {
2506 $hash{$date} = $self->getfield($date);
2508 # but if contract_end was explicitly specified, that overrides all else
2509 $hash{'contract_end'} = $opt->{'contract_end'}
2510 if $opt->{'contract_end'};
2512 # allow $opt->{'locationnum'} = '' to specifically set it to null
2513 # (i.e. customer default location)
2514 $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
2516 # usually this doesn't matter. the two cases where it does are:
2517 # 1. unused_credit_change + pkgpart change + setup fee on the new package
2519 # 2. (more importantly) changing a package before it's billed
2520 $hash{'waive_setup'} = $self->waive_setup;
2522 # if this package is scheduled for a future package change, preserve that
2523 $hash{'change_to_pkgnum'} = $self->change_to_pkgnum;
2525 my $custnum = $self->custnum;
2526 if ( $opt->{cust_main} ) {
2527 my $cust_main = $opt->{cust_main};
2528 unless ( $cust_main->custnum ) {
2529 my $error = $cust_main->insert( @{ $opt->{cust_main_insert_args}||[] } );
2531 $dbh->rollback if $oldAutoCommit;
2532 return "inserting customer record: $error";
2535 $custnum = $cust_main->custnum;
2538 $hash{'contactnum'} = $opt->{'contactnum'} if $opt->{'contactnum'};
2541 if ( $opt->{'cust_pkg'} ) {
2542 # The target package already exists; update it to show that it was
2543 # changed from this package.
2544 $cust_pkg = $opt->{'cust_pkg'};
2546 # follow all the above rules for date changes, etc.
2547 foreach (keys %hash) {
2548 $cust_pkg->set($_, $hash{$_});
2550 # except those that implement the future package change behavior
2551 foreach (qw(change_to_pkgnum start_date expire)) {
2552 $cust_pkg->set($_, '');
2555 $error = $cust_pkg->replace;
2558 # Create the new package.
2559 $cust_pkg = new FS::cust_pkg {
2560 custnum => $custnum,
2561 locationnum => $opt->{'locationnum'},
2562 ( map { $_ => ( $opt->{$_} || $self->$_() ) }
2563 qw( pkgpart quantity refnum salesnum )
2567 $error = $cust_pkg->insert( 'change' => 1,
2568 'allow_pkgpart' => $same_pkgpart );
2571 $dbh->rollback if $oldAutoCommit;
2572 return "inserting new package: $error";
2575 # Transfer services and cancel old package.
2576 # Enforce service limits only if this is a pkgpart change.
2577 local $FS::cust_svc::ignore_quantity;
2578 $FS::cust_svc::ignore_quantity = 1 if $same_pkgpart;
2579 $error = $self->transfer($cust_pkg);
2580 if ($error and $error == 0) {
2581 # $old_pkg->transfer failed.
2582 $dbh->rollback if $oldAutoCommit;
2583 return "transferring $error";
2586 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2587 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2588 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
2589 if ($error and $error == 0) {
2590 # $old_pkg->transfer failed.
2591 $dbh->rollback if $oldAutoCommit;
2592 return "converting $error";
2596 # We set unprotect_svcs when executing a "future package change". It's
2597 # not a user-interactive operation, so returning an error means the
2598 # package change will just fail. Rather than have that happen, we'll
2599 # let leftover services be deleted.
2600 if ($error > 0 and !$opt->{'unprotect_svcs'}) {
2601 # Transfers were successful, but we still had services left on the old
2602 # package. We can't change the package under this circumstances, so abort.
2603 $dbh->rollback if $oldAutoCommit;
2604 return "unable to transfer all services";
2607 #reset usage if changing pkgpart
2608 # AND usage rollover is off (otherwise adds twice, now and at package bill)
2609 if ($self->pkgpart != $cust_pkg->pkgpart) {
2610 my $part_pkg = $cust_pkg->part_pkg;
2611 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
2615 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
2618 $dbh->rollback if $oldAutoCommit;
2619 return "setting usage values: $error";
2622 # if NOT changing pkgpart, transfer any usage pools over
2623 foreach my $usage ($self->cust_pkg_usage) {
2624 $usage->set('pkgnum', $cust_pkg->pkgnum);
2625 $error = $usage->replace;
2627 $dbh->rollback if $oldAutoCommit;
2628 return "transferring usage pools: $error";
2633 # transfer usage pricing add-ons, if we're not changing pkgpart or if they were specified
2634 if ( $same_pkgpart || $opt->{'cust_pkg_usageprice'}) {
2635 my @old_cust_pkg_usageprice;
2636 if ($opt->{'cust_pkg_usageprice'}) {
2637 @old_cust_pkg_usageprice = @{ $opt->{'cust_pkg_usageprice'} };
2639 @old_cust_pkg_usageprice = $self->cust_pkg_usageprice;
2641 foreach my $old_cust_pkg_usageprice (@old_cust_pkg_usageprice) {
2642 my $new_cust_pkg_usageprice = new FS::cust_pkg_usageprice {
2643 'pkgnum' => $cust_pkg->pkgnum,
2644 'usagepricepart' => $old_cust_pkg_usageprice->usagepricepart,
2645 'quantity' => $old_cust_pkg_usageprice->quantity,
2647 $error = $new_cust_pkg_usageprice->insert;
2649 $dbh->rollback if $oldAutoCommit;
2650 return "Error transferring usage pricing add-on: $error";
2655 if (%new_discount && !$error) {
2657 # If discounts were explicitly specified in $opt
2658 $error = $cust_pkg->change_discount(%new_discount);
2660 $dbh->rollback if $oldAutoCommit;
2661 return "applying discounts: $error";
2664 } elsif ( $same_pkgpart ) {
2666 # transfer discounts, if we're not changing pkgpart
2667 foreach my $old_discount ($self->cust_pkg_discount_active) {
2668 # don't remove the old discount, we may still need to bill that package.
2669 my $new_discount = new FS::cust_pkg_discount {
2670 'pkgnum' => $cust_pkg->pkgnum,
2671 map { $_ => $old_discount->$_() }
2672 qw( discountnum months_used end_date usernum setuprecur ),
2674 $error = $new_discount->insert;
2676 $dbh->rollback if $oldAutoCommit;
2677 return "transferring discounts: $error";
2682 # transfer (copy) invoice details
2683 foreach my $detail ($self->cust_pkg_detail) {
2684 my $new_detail = FS::cust_pkg_detail->new({ $detail->hash });
2685 $new_detail->set('pkgdetailnum', '');
2686 $new_detail->set('pkgnum', $cust_pkg->pkgnum);
2687 $error = $new_detail->insert;
2689 $dbh->rollback if $oldAutoCommit;
2690 return "transferring package notes: $error";
2694 # transfer scheduled expire/adjourn reasons
2695 foreach my $action ('expire', 'adjourn') {
2696 if ( $cust_pkg->get($action) ) {
2697 my $reason = $self->last_cust_pkg_reason($action);
2699 $reason->set('pkgnum', $cust_pkg->pkgnum);
2700 $error = $reason->replace;
2702 $dbh->rollback if $oldAutoCommit;
2703 return "transferring $action reason: $error";
2711 if ( !$opt->{'cust_pkg'} ) {
2712 # Order any supplemental packages.
2713 my $part_pkg = $cust_pkg->part_pkg;
2714 my @old_supp_pkgs = $self->supplemental_pkgs;
2715 foreach my $link ($part_pkg->supp_part_pkg_link) {
2717 foreach (@old_supp_pkgs) {
2718 if ($_->pkgpart == $link->dst_pkgpart) {
2720 $_->pkgpart(0); # so that it can't match more than once
2724 # false laziness with FS::cust_main::Packages::order_pkg
2725 my $new = FS::cust_pkg->new({
2726 pkgpart => $link->dst_pkgpart,
2727 pkglinknum => $link->pkglinknum,
2728 custnum => $custnum,
2729 main_pkgnum => $cust_pkg->pkgnum,
2730 locationnum => $cust_pkg->locationnum,
2731 start_date => $cust_pkg->start_date,
2732 order_date => $cust_pkg->order_date,
2733 expire => $cust_pkg->expire,
2734 adjourn => $cust_pkg->adjourn,
2735 contract_end => $cust_pkg->contract_end,
2736 refnum => $cust_pkg->refnum,
2737 discountnum => $cust_pkg->discountnum,
2738 waive_setup => $cust_pkg->waive_setup,
2740 if ( $old and $opt->{'keep_dates'} ) {
2741 foreach (qw(setup bill last_bill)) {
2742 $new->set($_, $old->get($_));
2745 $error = $new->insert( allow_pkgpart => $same_pkgpart );
2748 $error ||= $old->transfer($new);
2750 if ( $error and $error > 0 ) {
2751 # no reason why this should ever fail, but still...
2752 $error = "Unable to transfer all services from supplemental package ".
2756 $dbh->rollback if $oldAutoCommit;
2759 push @new_supp_pkgs, $new;
2761 } # if !$opt->{'cust_pkg'}
2762 # because if there is one, then supplemental packages would already
2763 # have been created for it.
2765 #Good to go, cancel old package. Notify 'cancel' of whether to credit
2767 #Don't allow billing the package (preceding period packages and/or
2768 #outstanding usage) if we are keeping dates (i.e. location changing),
2769 #because the new package will be billed for the same date range.
2770 #Supplemental packages are also canceled here.
2772 # during scheduled changes, avoid canceling the package we just
2774 $self->set('change_to_pkgnum' => '');
2776 $error = $self->cancel(
2778 unused_credit => $unused_credit,
2779 nobill => $keep_dates,
2780 change_custnum => ( $self->custnum != $custnum ? $custnum : '' ),
2781 no_delay_cancel => 1,
2784 $dbh->rollback if $oldAutoCommit;
2785 return "canceling old package: $error";
2788 # transfer rt_field_charge, if we're not changing pkgpart
2789 # after billing of old package, before billing of new package
2790 if ( $same_pkgpart ) {
2791 foreach my $rt_field_charge ($self->rt_field_charge) {
2792 $rt_field_charge->set('pkgnum', $cust_pkg->pkgnum);
2793 $error = $rt_field_charge->replace;
2795 $dbh->rollback if $oldAutoCommit;
2796 return "transferring rt_field_charge: $error";
2801 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
2803 my $error = $cust_pkg->cust_main->bill(
2804 'pkg_list' => [ $cust_pkg, @new_supp_pkgs ]
2807 $dbh->rollback if $oldAutoCommit;
2808 return "billing new package: $error";
2812 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2818 =item change_later OPTION => VALUE...
2820 Schedule a package change for a later date. This actually orders the new
2821 package immediately, but sets its start date for a future date, and sets
2822 the current package to expire on the same date.
2824 If the package is already scheduled for a change, this can be called with
2825 'start_date' to change the scheduled date, or with pkgpart and/or
2826 locationnum to modify the package change. To cancel the scheduled change
2827 entirely, see C<abort_change>.
2835 The date for the package change. Required, and must be in the future.
2845 The pkgpart, locationnum, quantity and optional contract_end of the new
2846 package, with the same meaning as in C<change>.
2854 my $opt = ref($_[0]) ? shift : { @_ };
2856 # check contract_end, prevent adding/removing
2857 my $error = $self->_check_change($opt);
2858 return $error if $error;
2860 my $oldAutoCommit = $FS::UID::AutoCommit;
2861 local $FS::UID::AutoCommit = 0;
2864 my $cust_main = $self->cust_main;
2866 my $date = delete $opt->{'start_date'} or return 'start_date required';
2868 if ( $date <= time ) {
2869 $dbh->rollback if $oldAutoCommit;
2870 return "start_date $date is in the past";
2873 # If the user entered a new location, set it up now.
2874 if ( $opt->{'cust_location'} ) {
2875 $error = $opt->{'cust_location'}->find_or_insert;
2877 $dbh->rollback if $oldAutoCommit;
2878 return "creating location record: $error";
2880 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
2884 # Applies discounts to the newly created future_change package
2886 # If a new discount is the same as the old discount, carry over the
2887 # old discount's months_used/end_date fields too
2890 # Legacy behavior was to create the next package with no discount.
2891 # This behavior is preserved. Without the discount fields in $opt,
2892 # the new package will be created with no discounts.
2894 # parse discount information from $opt
2895 my %new_discount = $self->_parse_new_discounts($opt);
2897 if ( $self->change_to_pkgnum ) {
2898 my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
2899 my $new_pkgpart = $opt->{'pkgpart'}
2900 if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $change_to->pkgpart;
2901 my $new_locationnum = $opt->{'locationnum'}
2902 if $opt->{'locationnum'} and $opt->{'locationnum'} != $change_to->locationnum;
2903 my $new_quantity = $opt->{'quantity'}
2904 if $opt->{'quantity'} and $opt->{'quantity'} != $change_to->quantity;
2905 my $new_contract_end = $opt->{'contract_end'}
2906 if $opt->{'contract_end'} and $opt->{'contract_end'} != $change_to->contract_end;
2907 if ( $new_pkgpart or $new_locationnum or $new_quantity or $new_contract_end ) {
2908 # it hasn't been billed yet, so in principle we could just edit
2909 # it in place (w/o a package change), but that's bad form.
2910 # So change the package according to the new options...
2911 my $err_or_pkg = $change_to->change(%$opt);
2912 if ( ref $err_or_pkg ) {
2913 # Then set that package up for a future start.
2914 $self->set('change_to_pkgnum', $err_or_pkg->pkgnum);
2915 $self->set('expire', $date); # in case it's different
2916 $err_or_pkg->set('start_date', $date);
2917 $err_or_pkg->set('change_date', '');
2918 $err_or_pkg->set('change_pkgnum', '');
2920 $error = $self->replace ||
2921 $err_or_pkg->replace ||
2922 #because change() might've edited existing scheduled change in place
2923 (($err_or_pkg->pkgnum == $change_to->pkgnum) ? '' :
2924 $change_to->cancel('no_delay_cancel' => 1) ||
2925 $change_to->delete);
2927 $error = $err_or_pkg;
2929 } else { # change the start date only.
2930 $self->set('expire', $date);
2931 $change_to->set('start_date', $date);
2932 $error = $self->replace || $change_to->replace;
2935 if ( !$error && exists $opt->{waive_setup} ) {
2936 $change_to->set(waive_setup => $opt->{waive_setup} );
2937 $error = $change_to->insert();
2940 if ( !$error && %new_discount ) {
2941 $error = $change_to->change_discount(%new_discount);
2945 $dbh->rollback if $oldAutoCommit;
2948 $dbh->commit if $oldAutoCommit;
2951 } # if $self->change_to_pkgnum
2953 my $new_pkgpart = $opt->{'pkgpart'}
2954 if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $self->pkgpart;
2955 my $new_locationnum = $opt->{'locationnum'}
2956 if $opt->{'locationnum'} and $opt->{'locationnum'} != $self->locationnum;
2957 my $new_quantity = $opt->{'quantity'}
2958 if $opt->{'quantity'} and $opt->{'quantity'} != $self->quantity;
2959 my $new_contract_end = $opt->{'contract_end'}
2960 if $opt->{'contract_end'} and $opt->{'contract_end'} != $self->contract_end;
2962 return '' unless $new_pkgpart or $new_locationnum or $new_quantity or $new_contract_end; # wouldn't do anything
2964 # allow $opt->{'locationnum'} = '' to specifically set it to null
2965 # (i.e. customer default location)
2966 $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
2968 my $new = FS::cust_pkg->new( {
2969 custnum => $self->custnum,
2970 locationnum => $opt->{'locationnum'},
2971 start_date => $date,
2972 map { $_ => ( $opt->{$_} || $self->$_() ) }
2973 qw( pkgpart quantity refnum salesnum contract_end )
2975 $error = $new->insert('change' => 1,
2976 'allow_pkgpart' => ($new_pkgpart ? 0 : 1));
2978 if ( !$error && %new_discount ) {
2979 $error = $new->change_discount(%new_discount);
2983 $self->set('change_to_pkgnum', $new->pkgnum);
2984 $self->set('expire', $date);
2985 $error = $self->replace;
2989 $dbh->rollback if $oldAutoCommit;
2991 $dbh->commit if $oldAutoCommit;
2997 # Helper method reads $opt hashref from change() and change_later()
2998 # Returns a hash of %new_discount suitable for passing to change_discount()
2999 sub _parse_new_discounts {
3000 my ($self, $opt) = @_;
3002 croak "Bad parameter list" unless ref $opt;
3005 map { $_->setuprecur => $_ }
3006 qsearch('cust_pkg_discount', {
3007 pkgnum => $self->pkgnum,
3012 for my $type(qw|setup recur|) {
3014 if (exists $opt->{"${type}_discountnum"}) {
3015 $new_discount{$type} = {
3016 discountnum => $opt->{"${type}_discountnum"},
3017 amount => $opt->{"${type}_discountnum_amount"},
3018 percent => $opt->{"${type}_discountnum_percent"},
3019 months => $opt->{"${type}_discountnum_months"},
3023 # Specified discountnum same as old discountnum, carry over addl fields
3025 exists $opt->{"${type}_discountnum"}
3026 && exists $old_discount{$type}
3027 && $opt->{"${type}_discountnum"} eq $old_discount{$type}->discountnum
3029 $new_discount{$type}->{months} = $old_discount{$type}->months;
3030 $new_discount{$type}->{end_date} = $old_discount{$type}->end_date;
3033 # No new discount specified, carryover old discount
3034 # If we wanted to abandon legacy behavior, and always carry old discounts
3037 # if (!exists $new_discount{$type} && $old_discount{$type}) {
3038 # $new_discount{$type} = {
3039 # discountnum => $old_discount{$type}->discountnum,
3040 # amount => $old_discount{$type}->amount,
3041 # percent => $old_discount{$type}->percent,
3042 # months => $old_discount{$type}->months,
3043 # end_date => $old_discount{$type}->end_date,
3049 warn "_parse_new_discounts(), pkgnum: ".$self->pkgnum." \n";
3050 warn "Determine \%old_discount, \%new_discount: \n";
3051 warn Dumper(\%old_discount);
3052 warn Dumper(\%new_discount);
3060 Cancels a future package change scheduled by C<change_later>.
3066 my $oldAutoCommit = $FS::UID::AutoCommit;
3067 local $FS::UID::AutoCommit = 0;
3069 my $pkgnum = $self->change_to_pkgnum;
3070 my $change_to = FS::cust_pkg->by_key($pkgnum) if $pkgnum;
3072 $self->set('change_to_pkgnum', '');
3073 $self->set('expire', '');
3074 $error = $self->replace;
3076 $error ||= $change_to->cancel || $change_to->delete;
3079 if ( $oldAutoCommit ) {
3090 =item set_quantity QUANTITY
3092 Change the package's quantity field. This is one of the few package properties
3093 that can safely be changed without canceling and reordering the package
3094 (because it doesn't affect tax eligibility). Returns an error or an
3101 $self = $self->replace_old; # just to make sure
3102 $self->quantity(shift);
3106 =item set_salesnum SALESNUM
3108 Change the package's salesnum (sales person) field. This is one of the few
3109 package properties that can safely be changed without canceling and reordering
3110 the package (because it doesn't affect tax eligibility). Returns an error or
3117 $self = $self->replace_old; # just to make sure
3118 $self->salesnum(shift);
3120 # XXX this should probably reassign any credit that's already been given
3123 =item modify_charge OPTIONS
3125 Change the properties of a one-time charge. The following properties can
3126 be changed this way:
3127 - pkg: the package description
3128 - classnum: the package class
3129 - additional: arrayref of additional invoice details to add to this package
3131 and, I<if the charge has not yet been billed>:
3132 - start_date: the date when it will be billed
3133 - amount: the setup fee to be charged
3134 - quantity: the multiplier for the setup fee
3135 - separate_bill: whether to put the charge on a separate invoice
3137 If you pass 'adjust_commission' => 1, and the classnum changes, and there are
3138 commission credits linked to this charge, they will be recalculated.
3145 my $part_pkg = $self->part_pkg;
3146 my $pkgnum = $self->pkgnum;
3149 my $oldAutoCommit = $FS::UID::AutoCommit;
3150 local $FS::UID::AutoCommit = 0;
3152 return "Can't use modify_charge except on one-time charges"
3153 unless $part_pkg->freq eq '0';
3155 if ( length($opt{'pkg'}) and $part_pkg->pkg ne $opt{'pkg'} ) {
3156 $part_pkg->set('pkg', $opt{'pkg'});
3159 my %pkg_opt = $part_pkg->options;
3160 my $pkg_opt_modified = 0;
3162 $opt{'additional'} ||= [];
3165 foreach (grep /^additional/, keys %pkg_opt) {
3166 ($i) = ($_ =~ /^additional_info(\d+)$/);
3167 $old_additional[$i] = $pkg_opt{$_} if $i;
3168 delete $pkg_opt{$_};
3171 for ( $i = 0; exists($opt{'additional'}->[$i]); $i++ ) {
3172 $pkg_opt{ "additional_info$i" } = $opt{'additional'}->[$i];
3173 if (!exists($old_additional[$i])
3174 or $old_additional[$i] ne $opt{'additional'}->[$i])
3176 $pkg_opt_modified = 1;
3179 $pkg_opt_modified = 1 if scalar(@old_additional) != $i;
3180 $pkg_opt{'additional_count'} = $i if $i > 0;
3183 if ( exists($opt{'classnum'}) and $part_pkg->classnum ne $opt{'classnum'} )
3186 $old_classnum = $part_pkg->classnum;
3187 $part_pkg->set('classnum', $opt{'classnum'});
3190 if ( !$self->get('setup') ) {
3191 # not yet billed, so allow amount, setup_cost, quantity, start_date,
3194 if ( exists($opt{'amount'})
3195 and $part_pkg->option('setup_fee') != $opt{'amount'}
3196 and $opt{'amount'} > 0 ) {
3198 $pkg_opt{'setup_fee'} = $opt{'amount'};
3199 $pkg_opt_modified = 1;
3202 if ( exists($opt{'setup_cost'})
3203 and $part_pkg->setup_cost != $opt{'setup_cost'}
3204 and $opt{'setup_cost'} > 0 ) {
3206 $part_pkg->set('setup_cost', $opt{'setup_cost'});
3209 if ( exists($opt{'quantity'})
3210 and $opt{'quantity'} != $self->quantity
3211 and $opt{'quantity'} > 0 ) {
3213 $self->set('quantity', $opt{'quantity'});
3216 if ( exists($opt{'start_date'})
3217 and $opt{'start_date'} != $self->start_date ) {
3219 $self->set('start_date', $opt{'start_date'});
3222 if ( exists($opt{'separate_bill'})
3223 and $opt{'separate_bill'} ne $self->separate_bill ) {
3225 $self->set('separate_bill', $opt{'separate_bill'});
3229 } # else simply ignore them; the UI shouldn't allow editing the fields
3232 if ( exists($opt{'taxclass'})
3233 and $part_pkg->taxclass ne $opt{'taxclass'}) {
3235 $part_pkg->set('taxclass', $opt{'taxclass'});
3239 if ( $part_pkg->modified or $pkg_opt_modified ) {
3240 # can we safely modify the package def?
3241 # Yes, if it's not available for purchase, and this is the only instance
3243 if ( $part_pkg->disabled
3244 and FS::cust_pkg->count('pkgpart = '.$part_pkg->pkgpart) == 1
3245 and FS::quotation_pkg->count('pkgpart = '.$part_pkg->pkgpart) == 0
3247 $error = $part_pkg->replace( options => \%pkg_opt );
3250 $part_pkg = $part_pkg->clone;
3251 $part_pkg->set('disabled' => 'Y');
3252 $error = $part_pkg->insert( options => \%pkg_opt );
3253 # and associate this as yet-unbilled package to the new package def
3254 $self->set('pkgpart' => $part_pkg->pkgpart);
3257 $dbh->rollback if $oldAutoCommit;
3262 if ($self->modified) { # for quantity or start_date change, or if we had
3263 # to clone the existing package def
3264 my $error = $self->replace;
3265 return $error if $error;
3267 if (defined $old_classnum) {
3268 # fix invoice grouping records
3269 my $old_catname = $old_classnum
3270 ? FS::pkg_class->by_key($old_classnum)->categoryname
3272 my $new_catname = $opt{'classnum'}
3273 ? $part_pkg->pkg_class->categoryname
3275 if ( $old_catname ne $new_catname ) {
3276 foreach my $cust_bill_pkg ($self->cust_bill_pkg) {
3277 # (there should only be one...)
3278 my @display = qsearch( 'cust_bill_pkg_display', {
3279 'billpkgnum' => $cust_bill_pkg->billpkgnum,
3280 'section' => $old_catname,
3282 foreach (@display) {
3283 $_->set('section', $new_catname);
3284 $error = $_->replace;
3286 $dbh->rollback if $oldAutoCommit;
3290 } # foreach $cust_bill_pkg
3293 if ( $opt{'adjust_commission'} ) {
3294 # fix commission credits...tricky.
3295 foreach my $cust_event ($self->cust_event) {
3296 my $part_event = $cust_event->part_event;
3297 foreach my $table (qw(sales agent)) {
3299 "FS::part_event::Action::Mixin::credit_${table}_pkg_class";
3300 my $credit = qsearchs('cust_credit', {
3301 'eventnum' => $cust_event->eventnum,
3303 if ( $part_event->isa($class) ) {
3304 # Yes, this results in current commission rates being applied
3305 # retroactively to a one-time charge. For accounting purposes
3306 # there ought to be some kind of time limit on doing this.
3307 my $amount = $part_event->_calc_credit($self);
3308 if ( $credit and $credit->amount ne $amount ) {
3309 # Void the old credit.
3310 $error = $credit->void('Package class changed');
3312 $dbh->rollback if $oldAutoCommit;
3313 return "$error (adjusting commission credit)";
3316 # redo the event action to recreate the credit.
3318 eval { $part_event->do_action( $self, $cust_event ) };
3320 $dbh->rollback if $oldAutoCommit;
3323 } # if $part_event->isa($class)
3325 } # foreach $cust_event
3326 } # if $opt{'adjust_commission'}
3327 } # if defined $old_classnum
3329 $dbh->commit if $oldAutoCommit;
3333 sub process_bulk_cust_pkg {
3336 warn Dumper($param) if $DEBUG;
3338 my $new_part_pkg = qsearchs('part_pkg',
3339 { pkgpart => $param->{'new_pkgpart'} });
3340 die "Must select a new package definition\n" unless $new_part_pkg;
3342 #my $keep_dates = $param->{'keep_dates'} || 0;
3343 my $keep_dates = 1; # there is no good reason to turn this off
3345 my $oldAutoCommit = $FS::UID::AutoCommit;
3346 local $FS::UID::AutoCommit = 0;
3349 my @old_pkgpart = ref($param->{'old_pkgpart'}) ? @{ $param->{'old_pkgpart'} }
3350 : $param->{'old_pkgpart'};
3352 my @cust_pkgs = qsearch({
3353 'table' => 'cust_pkg',
3354 'extra_sql' => ' WHERE pkgpart IN ('.
3355 join(',', @old_pkgpart). ')',
3359 foreach my $old_cust_pkg ( @cust_pkgs ) {
3361 $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
3362 if ( $old_cust_pkg->getfield('cancel') ) {
3363 warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
3364 $old_cust_pkg->pkgnum."\n"
3368 warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
3370 my $error = $old_cust_pkg->change(
3371 'pkgpart' => $param->{'new_pkgpart'},
3372 'keep_dates' => $keep_dates
3374 if ( !ref($error) ) { # change returns the cust_pkg on success
3376 die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
3379 $dbh->commit if $oldAutoCommit;
3385 Returns the last bill date, or if there is no last bill date, the setup date.
3386 Useful for billing metered services.
3392 return $self->setfield('last_bill', $_[0]) if @_;
3393 return $self->getfield('last_bill') if $self->getfield('last_bill');
3394 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
3395 'edate' => $self->bill, } );
3396 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
3399 =item last_cust_pkg_reason ACTION
3401 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
3402 Returns false if there is no reason or the package is not currenly ACTION'd
3403 ACTION is one of adjourn, susp, cancel, or expire.
3407 sub last_cust_pkg_reason {
3408 my ( $self, $action ) = ( shift, shift );
3409 my $date = $self->get($action);
3411 'table' => 'cust_pkg_reason',
3412 'hashref' => { 'pkgnum' => $self->pkgnum,
3413 'action' => substr(uc($action), 0, 1),
3416 'order_by' => 'ORDER BY num DESC LIMIT 1',
3420 =item last_reason ACTION
3422 Returns the most recent ACTION FS::reason associated with the package.
3423 Returns false if there is no reason or the package is not currenly ACTION'd
3424 ACTION is one of adjourn, susp, cancel, or expire.
3429 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
3430 $cust_pkg_reason->reason
3431 if $cust_pkg_reason;
3436 Returns the definition for this billing item, as an FS::part_pkg object (see
3443 return $self->{'_pkgpart'} if $self->{'_pkgpart'};
3444 cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
3445 qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
3450 Returns the cancelled package this package was changed from, if any.
3456 return '' unless $self->change_pkgnum;
3457 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
3460 =item change_cust_main
3462 Returns the customter this package was detached to, if any.
3466 sub change_cust_main {
3468 return '' unless $self->change_custnum;
3469 qsearchs('cust_main', { 'custnum' => $self->change_custnum } );
3474 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
3481 $self->part_pkg->calc_setup($self, @_);
3486 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
3493 $self->part_pkg->calc_recur($self, @_);
3498 Calls the I<base_setup> of the FS::part_pkg object associated with this billing
3505 $self->part_pkg->base_setup($self, @_);
3510 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
3517 $self->part_pkg->base_recur($self, @_);
3522 Calls the I<calc_remain> of the FS::part_pkg object associated with this
3529 $self->part_pkg->calc_remain($self, @_);
3534 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
3541 $self->part_pkg->calc_cancel($self, @_);
3546 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
3552 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
3555 =item cust_pkg_detail [ DETAILTYPE ]
3557 Returns any customer package details for this package (see
3558 L<FS::cust_pkg_detail>).
3560 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
3564 sub cust_pkg_detail {
3566 my %hash = ( 'pkgnum' => $self->pkgnum );
3567 $hash{detailtype} = shift if @_;
3569 'table' => 'cust_pkg_detail',
3570 'hashref' => \%hash,
3571 'order_by' => 'ORDER BY weight, pkgdetailnum',
3575 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
3577 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
3579 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
3581 If there is an error, returns the error, otherwise returns false.
3585 sub set_cust_pkg_detail {
3586 my( $self, $detailtype, @details ) = @_;
3588 my $oldAutoCommit = $FS::UID::AutoCommit;
3589 local $FS::UID::AutoCommit = 0;
3592 foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
3593 my $error = $current->delete;
3595 $dbh->rollback if $oldAutoCommit;
3596 return "error removing old detail: $error";
3600 foreach my $detail ( @details ) {
3601 my $cust_pkg_detail = new FS::cust_pkg_detail {
3602 'pkgnum' => $self->pkgnum,
3603 'detailtype' => $detailtype,
3604 'detail' => $detail,
3606 my $error = $cust_pkg_detail->insert;
3608 $dbh->rollback if $oldAutoCommit;
3609 return "error adding new detail: $error";
3614 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3621 Returns the customer billing events (see L<FS::cust_event>) for this invoice.
3625 #false laziness w/cust_bill.pm
3629 'table' => 'cust_event',
3630 'addl_from' => 'JOIN part_event USING ( eventpart )',
3631 'hashref' => { 'tablenum' => $self->pkgnum },
3632 'extra_sql' => " AND eventtable = 'cust_pkg' ",
3636 =item num_cust_event
3638 Returns the number of customer billing events (see L<FS::cust_event>) for this package.
3642 #false laziness w/cust_bill.pm
3643 sub num_cust_event {
3645 my $sql = "SELECT COUNT(*) ". $self->_from_cust_event_where;
3646 $self->_prep_ex($sql, $self->pkgnum)->fetchrow_arrayref->[0];
3649 =item exists_cust_event
3651 Returns true if there are customer billing events (see L<FS::cust_event>) for this package. More efficient than using num_cust_event.
3655 sub exists_cust_event {
3657 my $sql = "SELECT 1 ". $self->_from_cust_event_where. " LIMIT 1";
3658 my $row = $self->_prep_ex($sql, $self->pkgnum)->fetchrow_arrayref;
3659 $row ? $row->[0] : '';
3662 sub _from_cust_event_where {
3664 " FROM cust_event JOIN part_event USING ( eventpart ) ".
3665 " WHERE tablenum = ? AND eventtable = 'cust_pkg' ";
3669 my( $self, $sql, @args ) = @_;
3670 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
3671 $sth->execute(@args) or die $sth->errstr. " executing $sql";
3675 =item part_pkg_currency_option OPTIONNAME
3677 Returns a two item list consisting of the currency of this customer, if any,
3678 and a value for the provided option. If the customer has a currency, the value
3679 is the option value the given name and the currency (see
3680 L<FS::part_pkg_currency>). Otherwise, if the customer has no currency, is the
3681 regular option value for the given name (see L<FS::part_pkg_option>).
3685 sub part_pkg_currency_option {
3686 my( $self, $optionname ) = @_;
3687 my $part_pkg = $self->part_pkg;
3688 if ( my $currency = $self->cust_main->currency ) {
3689 ($currency, $part_pkg->part_pkg_currency_option($currency, $optionname) );
3691 ('', $part_pkg->option($optionname) );
3695 =item cust_svc [ SVCPART ] (old, deprecated usage)
3697 =item cust_svc [ OPTION => VALUE ... ] (current usage)
3699 =item cust_svc_unsorted [ OPTION => VALUE ... ]
3701 Returns the services for this package, as FS::cust_svc objects (see
3702 L<FS::cust_svc>). Available options are svcpart and svcdb. If either is
3703 spcififed, returns only the matching services.
3705 As an optimization, use the cust_svc_unsorted version if you are not displaying
3712 cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
3713 $self->_sort_cust_svc( $self->cust_svc_unsorted_arrayref(@_) );
3716 sub cust_svc_unsorted {
3718 @{ $self->cust_svc_unsorted_arrayref(@_) };
3721 sub cust_svc_unsorted_arrayref {
3724 return [] unless $self->num_cust_svc(@_);
3727 if ( @_ && $_[0] =~ /^\d+/ ) {
3728 $opt{svcpart} = shift;
3729 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
3736 'select' => 'cust_svc.*, part_svc.*',
3737 'table' => 'cust_svc',
3738 'hashref' => { 'pkgnum' => $self->pkgnum },
3739 'addl_from' => 'LEFT JOIN part_svc USING ( svcpart )',
3741 $search{hashref}->{svcpart} = $opt{svcpart}
3743 $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{svcdb} )
3746 [ qsearch(\%search) ];
3750 =item overlimit [ SVCPART ]
3752 Returns the services for this package which have exceeded their
3753 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
3754 is specified, return only the matching services.
3760 return () unless $self->num_cust_svc(@_);
3761 grep { $_->overlimit } $self->cust_svc(@_);
3764 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
3766 Returns historical services for this package created before END TIMESTAMP and
3767 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
3768 (see L<FS::h_cust_svc>). If MODE is 'I' (for 'invoice'), services with the
3769 I<pkg_svc.hidden> flag will be omitted.
3775 warn "$me _h_cust_svc called on $self\n"
3778 my ($end, $start, $mode) = @_;
3780 local($FS::Record::qsearch_qualify_columns) = 0;
3782 my @cust_svc = $self->_sort_cust_svc(
3783 [ qsearch( 'h_cust_svc',
3784 { 'pkgnum' => $self->pkgnum, },
3785 FS::h_cust_svc->sql_h_search(@_),
3789 if ( defined($mode) && $mode eq 'I' ) {
3790 my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
3791 return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
3797 sub _sort_cust_svc {
3798 my( $self, $arrayref ) = @_;
3801 sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] };
3803 my %pkg_svc = map { $_->svcpart => $_ }
3804 qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
3809 my $pkg_svc = $pkg_svc{ $_->svcpart } || '';
3811 $pkg_svc ? $pkg_svc->primary_svc : '',
3812 $pkg_svc ? $pkg_svc->quantity : 0,
3819 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
3821 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
3823 Returns the number of services for this package. Available options are svcpart
3824 and svcdb. If either is spcififed, returns only the matching services.
3831 return $self->{'_num_cust_svc'}
3833 && exists($self->{'_num_cust_svc'})
3834 && $self->{'_num_cust_svc'} =~ /\d/;
3836 cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
3840 if ( @_ && $_[0] =~ /^\d+/ ) {
3841 $opt{svcpart} = shift;
3842 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
3848 my $select = 'SELECT COUNT(*) FROM cust_svc ';
3849 my $where = ' WHERE pkgnum = ? ';
3850 my @param = ($self->pkgnum);
3852 if ( $opt{'svcpart'} ) {
3853 $where .= ' AND svcpart = ? ';
3854 push @param, $opt{'svcpart'};
3856 if ( $opt{'svcdb'} ) {
3857 $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
3858 $where .= ' AND svcdb = ? ';
3859 push @param, $opt{'svcdb'};
3862 my $sth = dbh->prepare("$select $where") or die dbh->errstr;
3863 $sth->execute(@param) or die $sth->errstr;
3864 $sth->fetchrow_arrayref->[0];
3867 =item available_part_svc
3869 Returns a list of FS::part_svc objects representing services included in this
3870 package but not yet provisioned. Each FS::part_svc object also has an extra
3871 field, I<num_avail>, which specifies the number of available services.
3873 Accepts option I<provision_hold>; if true, only returns part_svc for which the
3874 associated pkg_svc has the provision_hold flag set.
3878 sub available_part_svc {
3882 my $pkg_quantity = $self->quantity || 1;
3884 grep { $_->num_avail > 0 }
3886 my $part_svc = $_->part_svc;
3887 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
3888 $pkg_quantity * $_->quantity - $self->num_cust_svc($_->svcpart);
3890 # more evil encapsulation breakage
3891 if ($part_svc->{'Hash'}{'num_avail'} > 0) {
3892 my @exports = $part_svc->part_export_did;
3893 $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
3898 grep { $opt{'provision_hold'} ? $_->provision_hold : 1 }
3899 $self->part_pkg->pkg_svc;
3902 =item part_svc [ OPTION => VALUE ... ]
3904 Returns a list of FS::part_svc objects representing provisioned and available
3905 services included in this package. Each FS::part_svc object also has the
3906 following extra fields:
3920 (services) - array reference containing the provisioned services, as cust_svc objects
3924 Accepts two options:
3928 =item summarize_size
3930 If true, will omit the extra cust_pkg_svc option for objects where num_cust_svc
3931 is this size or greater.
3933 =item hide_discontinued
3935 If true, will omit looking for services that are no longer avaialble in the
3943 #label -> ($cust_svc->label)[1]
3949 my $pkg_quantity = $self->quantity || 1;
3951 #XXX some sort of sort order besides numeric by svcpart...
3952 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
3954 my $part_svc = $pkg_svc->part_svc;
3955 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3956 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
3957 $part_svc->{'Hash'}{'num_avail'} =
3958 max( 0, $pkg_quantity * $pkg_svc->quantity - $num_cust_svc );
3959 $part_svc->{'Hash'}{'cust_pkg_svc'} =
3960 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
3961 unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
3962 && $num_cust_svc >= $opt{summarize_size};
3963 $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
3965 } $self->part_pkg->pkg_svc;
3967 unless ( $opt{hide_discontinued} ) {
3969 push @part_svc, map {
3971 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3972 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
3973 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
3974 $part_svc->{'Hash'}{'cust_pkg_svc'} =
3975 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
3977 } $self->extra_part_svc;
3984 =item extra_part_svc
3986 Returns a list of FS::part_svc objects corresponding to services in this
3987 package which are still provisioned but not (any longer) available in the
3992 sub extra_part_svc {
3995 my $pkgnum = $self->pkgnum;
3996 #my $pkgpart = $self->pkgpart;
3999 # 'table' => 'part_svc',
4002 # "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
4003 # WHERE pkg_svc.svcpart = part_svc.svcpart
4004 # AND pkg_svc.pkgpart = ?
4007 # AND 0 < ( SELECT COUNT(*) FROM cust_svc
4008 # LEFT JOIN cust_pkg USING ( pkgnum )
4009 # WHERE cust_svc.svcpart = part_svc.svcpart
4012 # 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
4015 #seems to benchmark slightly faster... (or did?)
4017 my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
4018 my $pkgparts = join(',', @pkgparts);
4021 #'select' => 'DISTINCT ON (svcpart) part_svc.*',
4022 #MySQL doesn't grok DISINCT ON
4023 'select' => 'DISTINCT part_svc.*',
4024 'table' => 'part_svc',
4026 "LEFT JOIN pkg_svc ON ( pkg_svc.svcpart = part_svc.svcpart
4027 AND pkg_svc.pkgpart IN ($pkgparts)
4030 LEFT JOIN cust_svc ON ( cust_svc.svcpart = part_svc.svcpart )
4031 LEFT JOIN cust_pkg USING ( pkgnum )
4034 'extra_sql' => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
4035 'extra_param' => [ [$self->pkgnum=>'int'] ],
4041 Returns a short status string for this package, currently:
4047 =item not yet billed
4049 =item one-time charge
4064 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
4066 return 'cancelled' if $self->get('cancel');
4067 return 'on hold' if $self->susp && ! $self->setup;
4068 return 'suspended' if $self->susp;
4069 return 'not yet billed' unless $self->setup;
4070 return 'one-time charge' if $freq =~ /^(0|$)/;
4074 =item ucfirst_status
4076 Returns the status with the first character capitalized.
4080 sub ucfirst_status {
4081 ucfirst(shift->status);
4086 Class method that returns the list of possible status strings for packages
4087 (see L<the status method|/status>). For example:
4089 @statuses = FS::cust_pkg->statuses();
4093 tie my %statuscolor, 'Tie::IxHash',
4094 'on hold' => 'FF00F5', #brighter purple!
4095 'not yet billed' => '009999', #teal? cyan?
4096 'one-time charge' => '0000CC', #blue #'000000',
4097 'active' => '00CC00',
4098 'suspended' => 'FF9900',
4099 'cancelled' => 'FF0000',
4103 my $self = shift; #could be class...
4104 #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
4105 # # mayble split btw one-time vs. recur
4116 Returns a hex triplet color string for this package's status.
4122 $statuscolor{$self->status};
4125 =item is_status_delay_cancel
4127 Returns true if part_pkg has option delay_cancel,
4128 cust_pkg status is 'suspended' and expire is set
4129 to cancel package within the next day (or however
4130 many days are set in global config part_pkg-delay_cancel-days.
4132 Accepts option I<part_pkg-delay_cancel-days> which should be
4133 the value of the config setting, to avoid looking it up again.
4135 This is not a real status, this only meant for hacking display
4136 values, because otherwise treating the package as suspended is
4137 really the whole point of the delay_cancel option.
4141 sub is_status_delay_cancel {
4142 my ($self,%opt) = @_;
4143 if ( $self->main_pkgnum and $self->pkglinknum ) {
4144 return $self->main_pkg->is_status_delay_cancel;
4146 return 0 unless $self->part_pkg->option('delay_cancel',1);
4147 return 0 unless $self->status eq 'suspended';
4148 return 0 unless $self->expire;
4149 my $expdays = $opt{'part_pkg-delay_cancel-days'};
4151 my $conf = new FS::Conf;
4152 $expdays = $conf->config('part_pkg-delay_cancel-days') || 1;
4154 my $expsecs = 60*60*24*$expdays;
4155 return 0 unless $self->expire < time + $expsecs;
4161 Returns a label for this package. (Currently "pkgnum: pkg - comment" or
4162 "pkg - comment" depending on user preference).
4168 my $label = $self->part_pkg->pkg_comment( cust_pkg=>$self, nopkgpart=>1 );
4169 $label = $self->pkgnum. ": $label"
4170 if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
4174 =item pkg_label_long
4176 Returns a long label for this package, adding the primary service's label to
4181 sub pkg_label_long {
4183 my $label = $self->pkg_label;
4184 my $cust_svc = $self->primary_cust_svc;
4185 $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
4191 Returns a customer-localized label for this package.
4197 $self->part_pkg->pkg_locale( $self->cust_main->locale );
4200 =item primary_cust_svc
4202 Returns a primary service (as FS::cust_svc object) if one can be identified.
4206 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
4208 sub primary_cust_svc {
4211 my @cust_svc = $self->cust_svc;
4213 return '' unless @cust_svc; #no serivces - irrelevant then
4215 return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
4217 # primary service as specified in the package definition
4218 # or exactly one service definition with quantity one
4219 my $svcpart = $self->part_pkg->svcpart;
4220 @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
4221 return $cust_svc[0] if scalar(@cust_svc) == 1;
4223 #couldn't identify one thing..
4229 Returns a list of lists, calling the label method for all services
4230 (see L<FS::cust_svc>) of this billing item.
4236 map { [ $_->label ] } $self->cust_svc;
4239 =item h_labels END_TIMESTAMP [, START_TIMESTAMP [, MODE [, LOCALE ] ] ]
4241 Like the labels method, but returns historical information on services that
4242 were active as of END_TIMESTAMP and (optionally) not cancelled before
4243 START_TIMESTAMP. If MODE is 'I' (for 'invoice'), services with the
4244 I<pkg_svc.hidden> flag will be omitted.
4246 If LOCALE is passed, service definition names will be localized.
4248 Returns a list of lists, calling the label method for all (historical)
4249 services (see L<FS::h_cust_svc>) of this billing item.
4255 my ($end, $start, $mode, $locale) = @_;
4256 warn "$me h_labels\n"
4258 map { [ $_->label($end, $start, $locale) ] }
4259 $self->h_cust_svc($end, $start, $mode);
4264 Like labels, except returns a simple flat list, and shortens long
4265 (currently >5 or the cust_bill-max_same_services configuration value) lists of
4266 identical services to one line that lists the service label and the number of
4267 individual services rather than individual items.
4272 shift->_labels_short( 'labels' ); # 'labels' takes no further arguments
4275 =item h_labels_short END_TIMESTAMP [, START_TIMESTAMP [, MODE [, LOCALE ] ] ]
4277 Like h_labels, except returns a simple flat list, and shortens long
4278 (currently >5 or the cust_bill-max_same_services configuration value) lists
4279 of identical services to one line that lists the service label and the
4280 number of individual services rather than individual items.
4284 sub h_labels_short {
4285 shift->_labels_short( 'h_labels', @_ );
4288 # takes a method name ('labels' or 'h_labels') and all its arguments;
4289 # maybe should be "shorten($self->h_labels( ... ) )"
4292 my( $self, $method ) = ( shift, shift );
4294 warn "$me _labels_short called on $self with $method method\n"
4297 my $conf = new FS::Conf;
4298 my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
4300 warn "$me _labels_short populating \%labels\n"
4304 #tie %labels, 'Tie::IxHash';
4305 push @{ $labels{$_->[0]} }, $_->[1]
4306 foreach $self->$method(@_);
4308 warn "$me _labels_short populating \@labels\n"
4312 foreach my $label ( keys %labels ) {
4314 my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
4315 my $num = scalar(@values);
4316 warn "$me _labels_short $num items for $label\n"
4319 if ( $num > $max_same_services ) {
4320 warn "$me _labels_short more than $max_same_services, so summarizing\n"
4322 push @labels, "$label ($num)";
4324 if ( $conf->exists('cust_bill-consolidate_services') ) {
4325 warn "$me _labels_short consolidating services\n"
4327 # push @labels, "$label: ". join(', ', @values);
4329 my $detail = "$label: ";
4330 $detail .= shift(@values). ', '
4332 && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
4334 push @labels, $detail;
4336 warn "$me _labels_short done consolidating services\n"
4339 warn "$me _labels_short adding service data\n"
4341 push @labels, map { "$label: $_" } @values;
4352 Returns the parent customer object (see L<FS::cust_main>).
4356 Returns the balance for this specific package, when using
4357 experimental package balance.
4363 $self->cust_main->balance_pkgnum( $self->pkgnum );
4366 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
4370 Returns the location object, if any (see L<FS::cust_location>).
4372 =item cust_location_or_main
4374 If this package is associated with a location, returns the locaiton (see
4375 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
4377 =item location_label [ OPTION => VALUE ... ]
4379 Returns the label of the location object (see L<FS::cust_location>).
4383 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
4385 =item tax_locationnum
4387 Returns the foreign key to a L<FS::cust_location> object for calculating
4388 tax on this package, as determined by the C<tax-pkg_address> and
4389 C<tax-ship_address> configuration flags.
4393 sub tax_locationnum {
4395 my $conf = FS::Conf->new;
4396 if ( $conf->exists('tax-pkg_address') ) {
4397 return $self->locationnum;
4399 elsif ( $conf->exists('tax-ship_address') ) {
4400 return $self->cust_main->ship_locationnum;
4403 return $self->cust_main->bill_locationnum;
4409 Returns the L<FS::cust_location> object for tax_locationnum.
4415 my $conf = FS::Conf->new;
4416 if ( $conf->exists('tax-pkg_address') and $self->locationnum ) {
4417 return FS::cust_location->by_key($self->locationnum);
4419 elsif ( $conf->exists('tax-ship_address') ) {
4420 return $self->cust_main->ship_location;
4423 return $self->cust_main->bill_location;
4427 =item seconds_since TIMESTAMP
4429 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
4430 package have been online since TIMESTAMP, according to the session monitor.
4432 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
4433 L<Time::Local> and L<Date::Parse> for conversion functions.
4438 my($self, $since) = @_;
4441 foreach my $cust_svc (
4442 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
4444 $seconds += $cust_svc->seconds_since($since);
4451 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
4453 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
4454 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
4457 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
4458 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
4464 sub seconds_since_sqlradacct {
4465 my($self, $start, $end) = @_;
4469 foreach my $cust_svc (
4471 my $part_svc = $_->part_svc;
4472 $part_svc->svcdb eq 'svc_acct'
4473 && scalar($part_svc->part_export_usage);
4476 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
4483 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
4485 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
4486 in this package for sessions ending between TIMESTAMP_START (inclusive) and
4490 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
4491 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
4496 sub attribute_since_sqlradacct {
4497 my($self, $start, $end, $attrib) = @_;
4501 foreach my $cust_svc (
4503 my $part_svc = $_->part_svc;
4504 scalar($part_svc->part_export_usage);
4507 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
4519 my( $self, $value ) = @_;
4520 if ( defined($value) ) {
4521 $self->setfield('quantity', $value);
4523 $self->getfield('quantity') || 1;
4526 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
4528 Transfers as many services as possible from this package to another package.
4530 The destination package can be specified by pkgnum by passing an FS::cust_pkg
4531 object. The destination package must already exist.
4533 Services are moved only if the destination allows services with the correct
4534 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
4535 this option with caution! No provision is made for export differences
4536 between the old and new service definitions. Probably only should be used
4537 when your exports for all service definitions of a given svcdb are identical.
4538 (attempt a transfer without it first, to move all possible svcpart-matching
4541 Any services that can't be moved remain in the original package.
4543 Returns an error, if there is one; otherwise, returns the number of services
4544 that couldn't be moved.
4549 my ($self, $dest_pkgnum, %opt) = @_;
4555 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
4556 $dest = $dest_pkgnum;
4557 $dest_pkgnum = $dest->pkgnum;
4559 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
4562 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
4564 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
4565 $target{$pkg_svc->svcpart} = $pkg_svc->quantity * ( $dest->quantity || 1 );
4568 unless ( $self->pkgnum == $dest->pkgnum ) {
4569 foreach my $cust_svc ($dest->cust_svc) {
4570 $target{$cust_svc->svcpart}--;
4574 my %svcpart2svcparts = ();
4575 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
4576 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
4577 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
4578 next if exists $svcpart2svcparts{$svcpart};
4579 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
4580 $svcpart2svcparts{$svcpart} = [
4582 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
4584 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
4585 'svcpart' => $_ } );
4587 $pkg_svc ? $pkg_svc->primary_svc : '',
4588 $pkg_svc ? $pkg_svc->quantity : 0,
4592 grep { $_ != $svcpart }
4594 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
4596 warn "alternates for svcpart $svcpart: ".
4597 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
4603 foreach my $cust_svc ($self->cust_svc) {
4604 my $svcnum = $cust_svc->svcnum;
4606 if ( $target{$cust_svc->svcpart} > 0
4607 or $FS::cust_svc::ignore_quantity # maybe should be a 'force' option
4610 $target{$cust_svc->svcpart}--;
4612 local $FS::cust_svc::ignore_quantity = 1
4613 if $self->pkgnum == $dest->pkgnum;
4615 #why run replace at all in the $self->pkgnum == $dest->pkgnum case?
4616 # we do want to trigger location and pkg_change exports, but
4617 # without pkgnum changing from an old to new package, cust_svc->replace
4618 # doesn't know how to trigger those. :/
4619 # does this mean we scrap the whole idea of "safe to modify it in place",
4620 # or do we special-case and pass the info needed to cust_svc->replace? :/
4622 my $new = new FS::cust_svc { $cust_svc->hash };
4623 $new->pkgnum($dest_pkgnum);
4624 $error = $new->replace($cust_svc);
4626 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
4629 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
4630 warn "alternates to consider: ".
4631 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
4634 my @alternate = grep {
4635 warn "considering alternate svcpart $_: ".
4636 "$target{$_} available in new package\n"
4639 } @{$svcpart2svcparts{$cust_svc->svcpart}};
4642 warn "alternate(s) found\n" if $DEBUG;
4643 my $change_svcpart = $alternate[0];
4644 $target{$change_svcpart}--;
4645 my $new = new FS::cust_svc { $cust_svc->hash };
4646 $new->svcpart($change_svcpart);
4647 $new->pkgnum($dest_pkgnum);
4648 $error = $new->replace($cust_svc);
4658 my @label = $cust_svc->label;
4659 return "$label[0] $label[1]: $error";
4666 =item grab_svcnums SVCNUM, SVCNUM ...
4668 Change the pkgnum for the provided services to this packages. If there is an
4669 error, returns the error, otherwise returns false.
4677 my $oldAutoCommit = $FS::UID::AutoCommit;
4678 local $FS::UID::AutoCommit = 0;
4681 foreach my $svcnum (@svcnum) {
4682 my $cust_svc = qsearchs('cust_svc', { svcnum=>$svcnum } ) or do {
4683 $dbh->rollback if $oldAutoCommit;
4684 return "unknown svcnum $svcnum";
4686 $cust_svc->pkgnum( $self->pkgnum );
4687 my $error = $cust_svc->replace;
4689 $dbh->rollback if $oldAutoCommit;
4694 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4701 This method is deprecated. See the I<depend_jobnum> option to the insert and
4702 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
4706 #looks like this is still used by the order_pkg and change_pkg methods in
4707 # ClientAPI/MyAccount, need to look into those before removing
4711 my $oldAutoCommit = $FS::UID::AutoCommit;
4712 local $FS::UID::AutoCommit = 0;
4715 foreach my $cust_svc ( $self->cust_svc ) {
4716 #false laziness w/svc_Common::insert
4717 my $svc_x = $cust_svc->svc_x;
4718 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
4719 my $error = $part_export->export_insert($svc_x);
4721 $dbh->rollback if $oldAutoCommit;
4727 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4732 =item export_pkg_change OLD_CUST_PKG
4734 Calls the "pkg_change" export action for all services attached to this package.
4738 sub export_pkg_change {
4739 my( $self, $old ) = ( shift, shift );
4741 my $oldAutoCommit = $FS::UID::AutoCommit;
4742 local $FS::UID::AutoCommit = 0;
4745 foreach my $svc_x ( map $_->svc_x, $self->cust_svc ) {
4746 my $error = $svc_x->export('pkg_change', $self, $old);
4748 $dbh->rollback if $oldAutoCommit;
4753 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4760 Associates this package with a (suspension or cancellation) reason (see
4761 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
4764 Available options are:
4770 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.
4774 the access_user (see L<FS::access_user>) providing the reason
4782 the action (cancel, susp, adjourn, expire) associated with the reason
4786 If there is an error, returns the error, otherwise returns false.
4791 my ($self, %options) = @_;
4793 my $otaker = $options{reason_otaker} ||
4794 $FS::CurrentUser::CurrentUser->username;
4797 if ( $options{'reason'} =~ /^(\d+)$/ ) {
4801 } elsif ( ref($options{'reason'}) ) {
4803 return 'Enter a new reason (or select an existing one)'
4804 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
4806 my $reason = new FS::reason({
4807 'reason_type' => $options{'reason'}->{'typenum'},
4808 'reason' => $options{'reason'}->{'reason'},
4810 my $error = $reason->insert;
4811 return $error if $error;
4813 $reasonnum = $reason->reasonnum;
4816 return "Unparseable reason: ". $options{'reason'};
4819 my $cust_pkg_reason =
4820 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
4821 'reasonnum' => $reasonnum,
4822 'otaker' => $otaker,
4823 'action' => substr(uc($options{'action'}),0,1),
4824 'date' => $options{'date'}
4829 $cust_pkg_reason->insert;
4832 =item insert_discount
4834 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
4835 inserting a new discount on the fly (see L<FS::discount>).
4837 This will look at the cust_pkg for a pseudo-field named "setup_discountnum",
4838 and if present, will create a setup discount. If the discountnum is -1,
4839 a new discount definition will be inserted using the value in
4840 "setup_discountnum_amount" or "setup_discountnum_percent". Likewise for recur.
4842 If there is an error, returns the error, otherwise returns false.
4846 sub insert_discount {
4847 #my ($self, %options) = @_;
4850 foreach my $x (qw(setup recur)) {
4851 if ( my $discountnum = $self->get("${x}_discountnum") ) {
4852 my $cust_pkg_discount = FS::cust_pkg_discount->new( {
4853 'pkgnum' => $self->pkgnum,
4854 'discountnum' => $discountnum,
4857 'end_date' => '', #XXX
4858 #for the create a new discount case
4859 'amount' => $self->get("${x}_discountnum_amount"),
4860 'percent' => $self->get("${x}_discountnum_percent"),
4861 'months' => $self->get("${x}_discountnum_months"),
4863 if ( $x eq 'setup' ) {
4864 $cust_pkg_discount->setup('Y');
4865 $cust_pkg_discount->months('');
4867 my $error = $cust_pkg_discount->insert;
4868 return $error if $error;
4875 =item change_discount %opt
4877 Method checks if the given values represent a change in either setup or
4878 discount level. If so, the existing discounts are revoked, the new
4879 discounts are recorded.
4883 $error = change_discount(
4886 # -1: Indicates a "custom discount"
4887 # 0: Indicates to remove any discount
4888 # >0: discountnum to apply
4889 discountnum => [-1, 0, discountnum],
4891 # When discountnum is "-1" to indicate custom discount, include
4892 # the additional fields:
4893 amount => AMOUNT_DISCOUNT
4894 percent => PERCENTAGE_DISCOUNT
4904 sub change_discount {
4905 my ($self, %opt) = @_;
4906 return "change_discount() called with bad \%opt"
4910 return "change_discount() called with unknown bad key $_"
4911 unless $_ eq 'setup' || $_ eq 'recur';
4915 qsearch('cust_pkg_discount',{
4916 pkgnum => $self->pkgnum,
4921 warn "change_discount() pkgnum: ".$self->pkgnum." \n";
4922 warn "change_discount() \%opt: \n";
4928 for my $type (qw|setup recur|) {
4929 next unless ref $opt{$type};
4930 my %change = %{$opt{$type}};
4932 return "change_discount() called with bad \$opt($type)"
4933 unless $change{discountnum} =~ /^-?\d+$/;
4935 if ($change{discountnum} eq 0) {
4936 # Removing old discount
4939 push @to_be_disabled, grep {$_->setuprecur eq $type} @old_discount;
4944 $_->discountnum eq $change{discountnum}
4945 && $_->setuprecur eq $type
4948 # Duplicate, disregard this entry
4952 # Mark any discounts we're replacing
4953 push @to_be_disabled, grep{ $_->setuprecur eq $type} @old_discount;
4960 # If we still have changes queued, pass them to insert_discount()
4961 # by setting values into object fields
4962 for my $type (keys %opt) {
4963 $self->set("${type}_discountnum", $opt{$type}->{discountnum});
4965 if ($opt{$type}->{discountnum} eq '-1') {
4966 $self->set("${type}_discountnum_${_}", $opt{$type}->{$_})
4967 for qw(amount percent months);
4973 warn "change_discount() \% opt before insert \n";
4975 warn "\@to_be_disabled \n";
4976 warn Dumper \@to_be_disabled;
4979 # Roll these updates into a transaction
4980 my $oldAutoCommit = $FS::UID::AutoCommit;
4981 local $FS::UID::AutoCommit = 0;
4986 # The "waive setup fee" flag has traditionally been handled by setting
4987 # $cust_pkg->waive_setup_fee = Y. This has been appropriately, and separately
4988 # handled, and it operates on a differetnt table than cust_pkg_discount,
4989 # so the "-2 for waive setup fee" option is not being reimplemented
4990 # here. Perhaps this may change later.
4992 # When a setup discount is entered, we still need unset waive_setup
4993 if ( $opt{setup} && $opt{setup} > -2 && $self->waive_setup ) {
4994 $self->set(waive_setup => '');
4995 $error = $self->replace();
4998 # Create new discounts
4999 $error ||= $self->insert_discount();
5001 # Disabling old discounts
5002 for my $tbd (@to_be_disabled) {
5004 $tbd->set(disabled => 'Y');
5005 $error = $tbd->replace();
5010 $dbh->rollback if $oldAutoCommit;
5014 $dbh->commit if $oldAutoCommit;
5018 =item set_usage USAGE_VALUE_HASHREF
5020 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
5021 to which they should be set (see L<FS::svc_acct>). Currently seconds,
5022 upbytes, downbytes, and totalbytes are appropriate keys.
5024 All svc_accts which are part of this package have their values reset.
5029 my ($self, $valueref, %opt) = @_;
5031 #only svc_acct can set_usage for now
5032 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
5033 my $svc_x = $cust_svc->svc_x;
5034 $svc_x->set_usage($valueref, %opt)
5035 if $svc_x->can("set_usage");
5039 =item recharge USAGE_VALUE_HASHREF
5041 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
5042 to which they should be set (see L<FS::svc_acct>). Currently seconds,
5043 upbytes, downbytes, and totalbytes are appropriate keys.
5045 All svc_accts which are part of this package have their values incremented.
5050 my ($self, $valueref) = @_;
5052 #only svc_acct can set_usage for now
5053 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
5054 my $svc_x = $cust_svc->svc_x;
5055 $svc_x->recharge($valueref)
5056 if $svc_x->can("recharge");
5060 =item apply_usageprice
5064 sub apply_usageprice {
5067 my $oldAutoCommit = $FS::UID::AutoCommit;
5068 local $FS::UID::AutoCommit = 0;
5073 foreach my $cust_pkg_usageprice ( $self->cust_pkg_usageprice ) {
5074 $error ||= $cust_pkg_usageprice->apply;
5078 $dbh->rollback if $oldAutoCommit;
5079 die "error applying part_pkg_usageprice add-ons, pkgnum ". $self->pkgnum.
5082 $dbh->commit if $oldAutoCommit;
5088 =item cust_pkg_discount
5090 =item cust_pkg_discount_active
5094 sub cust_pkg_discount_active {
5096 grep { $_->status eq 'active' } $self->cust_pkg_discount;
5099 =item cust_pkg_usage
5101 Returns a list of all voice usage counters attached to this package.
5103 =item apply_usage OPTIONS
5105 Takes the following options:
5106 - cdr: a call detail record (L<FS::cdr>)
5107 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
5108 - minutes: the maximum number of minutes to be charged
5110 Finds available usage minutes for a call of this class, and subtracts
5111 up to that many minutes from the usage pool. If the usage pool is empty,
5112 and the C<cdr-minutes_priority> global config option is set, minutes may
5113 be taken from other calls as well. Either way, an allocation record will
5114 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
5115 number of minutes of usage applied to the call.
5120 my ($self, %opt) = @_;
5121 my $cdr = $opt{cdr};
5122 my $rate_detail = $opt{rate_detail};
5123 my $minutes = $opt{minutes};
5124 my $classnum = $rate_detail->classnum;
5125 my $pkgnum = $self->pkgnum;
5126 my $custnum = $self->custnum;
5128 my $oldAutoCommit = $FS::UID::AutoCommit;
5129 local $FS::UID::AutoCommit = 0;
5132 my $order = FS::Conf->new->config('cdr-minutes_priority');
5136 $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
5138 $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
5140 my @usage_recs = qsearch({
5141 'table' => 'cust_pkg_usage',
5142 'addl_from' => ' JOIN part_pkg_usage USING (pkgusagepart)'.
5143 ' JOIN cust_pkg USING (pkgnum)'.
5144 ' JOIN part_pkg_usage_class USING (pkgusagepart)',
5145 'select' => 'cust_pkg_usage.*',
5146 'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
5147 " ( cust_pkg.custnum = $custnum AND ".
5148 " part_pkg_usage.shared IS NOT NULL ) ) AND ".
5149 $is_classnum . ' AND '.
5150 " cust_pkg_usage.minutes > 0",
5151 'order_by' => " ORDER BY priority ASC",
5154 my $orig_minutes = $minutes;
5156 while (!$error and $minutes > 0 and @usage_recs) {
5157 my $cust_pkg_usage = shift @usage_recs;
5158 $cust_pkg_usage->select_for_update;
5159 my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
5160 pkgusagenum => $cust_pkg_usage->pkgusagenum,
5161 acctid => $cdr->acctid,
5162 minutes => min($cust_pkg_usage->minutes, $minutes),
5164 $cust_pkg_usage->set('minutes',
5165 $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes
5167 $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
5168 $minutes -= $cdr_cust_pkg_usage->minutes;
5170 if ( $order and $minutes > 0 and !$error ) {
5171 # then try to steal minutes from another call
5173 'table' => 'cdr_cust_pkg_usage',
5174 'addl_from' => ' JOIN cust_pkg_usage USING (pkgusagenum)'.
5175 ' JOIN part_pkg_usage USING (pkgusagepart)'.
5176 ' JOIN cust_pkg USING (pkgnum)'.
5177 ' JOIN part_pkg_usage_class USING (pkgusagepart)'.
5178 ' JOIN cdr USING (acctid)',
5179 'select' => 'cdr_cust_pkg_usage.*',
5180 'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
5181 " ( cust_pkg.pkgnum = $pkgnum OR ".
5182 " ( cust_pkg.custnum = $custnum AND ".
5183 " part_pkg_usage.shared IS NOT NULL ) ) AND ".
5184 " part_pkg_usage_class.classnum = $classnum",
5185 'order_by' => ' ORDER BY part_pkg_usage.priority ASC',
5187 if ( $order eq 'time' ) {
5188 # find CDRs that are using minutes, but have a later startdate
5190 my $startdate = $cdr->startdate;
5191 if ($startdate !~ /^\d+$/) {
5192 die "bad cdr startdate '$startdate'";
5194 $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
5195 # minimize needless reshuffling
5196 $search{'order_by'} .= ', cdr.startdate DESC';
5198 # XXX may not work correctly with rate_time schedules. Could
5199 # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
5201 $search{'addl_from'} .=
5202 ' JOIN rate_detail'.
5203 ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
5204 if ( $order eq 'rate_high' ) {
5205 $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
5206 $rate_detail->min_charge;
5207 $search{'order_by'} .= ', rate_detail.min_charge ASC';
5208 } elsif ( $order eq 'rate_low' ) {
5209 $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
5210 $rate_detail->min_charge;
5211 $search{'order_by'} .= ', rate_detail.min_charge DESC';
5213 # this should really never happen
5214 die "invalid cdr-minutes_priority value '$order'\n";
5217 my @cdr_usage_recs = qsearch(\%search);
5219 while (!$error and @cdr_usage_recs and $minutes > 0) {
5220 my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
5221 my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
5222 my $old_cdr = $cdr_cust_pkg_usage->cdr;
5223 $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
5224 $cdr_cust_pkg_usage->select_for_update;
5225 $old_cdr->select_for_update;
5226 $cust_pkg_usage->select_for_update;
5227 # in case someone else stole the usage from this CDR
5228 # while waiting for the lock...
5229 next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
5230 # steal the usage allocation and flag the old CDR for reprocessing
5231 $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
5232 # if the allocation is more minutes than we need, adjust it...
5233 my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
5235 $cdr_cust_pkg_usage->set('minutes', $minutes);
5236 $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
5237 $error = $cust_pkg_usage->replace;
5239 #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
5240 $error ||= $cdr_cust_pkg_usage->replace;
5241 # deduct the stolen minutes
5242 $minutes -= $cdr_cust_pkg_usage->minutes;
5244 # after all minute-stealing is done, reset the affected CDRs
5245 foreach (values %reproc_cdrs) {
5246 $error ||= $_->set_status('');
5247 # XXX or should we just call $cdr->rate right here?
5248 # it's not like we can create a loop this way, since the min_charge
5249 # or call time has to go monotonically in one direction.
5250 # we COULD get some very deep recursions going, though...
5252 } # if $order and $minutes
5255 die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
5257 $dbh->commit if $oldAutoCommit;
5258 return $orig_minutes - $minutes;
5262 =item supplemental_pkgs
5264 Returns a list of all packages supplemental to this one.
5268 sub supplemental_pkgs {
5270 qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
5275 Returns the package that this one is supplemental to, if any.
5281 if ( $self->main_pkgnum ) {
5282 return FS::cust_pkg->by_key($self->main_pkgnum);
5289 =head1 CLASS METHODS
5295 Returns an SQL expression identifying recurring packages.
5299 sub recurring_sql { "
5300 '0' != ( select freq from part_pkg
5301 where cust_pkg.pkgpart = part_pkg.pkgpart )
5306 Returns an SQL expression identifying one-time packages.
5311 '0' = ( select freq from part_pkg
5312 where cust_pkg.pkgpart = part_pkg.pkgpart )
5317 Returns an SQL expression identifying ordered packages (recurring packages not
5323 $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
5328 Returns an SQL expression identifying active packages.
5333 $_[0]->recurring_sql. "
5334 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
5335 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
5336 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
5339 =item not_yet_billed_sql
5341 Returns an SQL expression identifying packages which have not yet been billed.
5345 sub not_yet_billed_sql { "
5346 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
5347 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
5348 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
5353 Returns an SQL expression identifying inactive packages (one-time packages
5354 that are otherwise unsuspended/uncancelled).
5358 sub inactive_sql { "
5359 ". $_[0]->onetime_sql(). "
5360 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
5361 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
5362 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
5367 Returns an SQL expression identifying on-hold packages.
5372 #$_[0]->recurring_sql(). ' AND '.
5374 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
5375 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
5376 AND ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
5383 Returns an SQL expression identifying suspended packages.
5387 sub suspended_sql { susp_sql(@_); }
5389 #$_[0]->recurring_sql(). ' AND '.
5391 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
5392 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
5393 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
5400 Returns an SQL exprression identifying cancelled packages.
5404 sub cancelled_sql { cancel_sql(@_); }
5406 #$_[0]->recurring_sql(). ' AND '.
5407 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
5410 =item ncancelled_recurring_sql
5412 Returns an SQL expression identifying un-cancelled, recurring packages.
5416 sub ncancelled_recurring_sql {
5417 $_[0]->recurring_sql().
5418 " AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 ) ";
5423 Returns an SQL expression to give the package status as a string.
5429 WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
5430 WHEN ( cust_pkg.susp IS NOT NULL AND cust_pkg.setup IS NULL ) THEN 'on hold'
5431 WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
5432 WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
5433 WHEN ".onetime_sql()." THEN 'one-time charge'
5440 Returns a list of two package counts. The first is a count of packages
5441 based on the supplied criteria and the second is the count of residential
5442 packages with those same criteria. Criteria are specified as in the search
5448 my ($class, $params) = @_;
5450 my $sql_query = $class->search( $params );
5452 my $count_sql = delete($sql_query->{'count_query'});
5453 $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
5454 or die "couldn't parse count_sql";
5456 my $count_sth = dbh->prepare($count_sql)
5457 or die "Error preparing $count_sql: ". dbh->errstr;
5459 or die "Error executing $count_sql: ". $count_sth->errstr;
5460 my $count_arrayref = $count_sth->fetchrow_arrayref;
5462 return ( @$count_arrayref );
5466 =item fcc_477_record
5468 Returns a fcc_477 record based on option name.
5472 sub fcc_477_record {
5473 my ($self, $option_name) = @_;
5475 my $fcc_record = qsearchs({
5476 'table' => 'part_pkg_fcc_option',
5477 'hashref' => { 'pkgpart' => $self->{Hash}->{pkgpart}, 'fccoptionname' => $option_name, },
5480 return ( $fcc_record );
5484 =item tax_locationnum_sql
5486 Returns an SQL expression for the tax location for a package, based
5487 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
5491 sub tax_locationnum_sql {
5492 my $conf = FS::Conf->new;
5493 if ( $conf->exists('tax-pkg_address') ) {
5494 'cust_pkg.locationnum';
5496 elsif ( $conf->exists('tax-ship_address') ) {
5497 'cust_main.ship_locationnum';
5500 'cust_main.bill_locationnum';
5506 Returns a list: the first item is an SQL fragment identifying matching
5507 packages/customers via location (taking into account shipping and package
5508 address taxation, if enabled), and subsequent items are the parameters to
5509 substitute for the placeholders in that fragment.
5514 my($class, %opt) = @_;
5515 my $ornull = $opt{'ornull'};
5517 my $conf = new FS::Conf;
5519 # '?' placeholders in _location_sql_where
5520 my $x = $ornull ? 3 : 2;
5531 if ( $conf->exists('tax-ship_address') ) {
5534 ( ( ship_last IS NULL OR ship_last = '' )
5535 AND ". _location_sql_where('cust_main', '', $ornull ). "
5537 OR ( ship_last IS NOT NULL AND ship_last != ''
5538 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
5541 # AND payby != 'COMP'
5543 @main_param = ( @bill_param, @bill_param );
5547 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
5548 @main_param = @bill_param;
5554 if ( $conf->exists('tax-pkg_address') ) {
5556 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
5559 ( cust_pkg.locationnum IS NULL AND $main_where )
5560 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
5563 @param = ( @main_param, @bill_param );
5567 $where = $main_where;
5568 @param = @main_param;
5576 #subroutine, helper for location_sql
5577 sub _location_sql_where {
5579 my $prefix = @_ ? shift : '';
5580 my $ornull = @_ ? shift : '';
5582 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
5584 $ornull = $ornull ? ' OR ? IS NULL ' : '';
5586 my $or_empty_city = " OR ( ? = '' AND $table.${prefix}city IS NULL )";
5587 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL )";
5588 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL )";
5590 my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
5592 # ( $table.${prefix}city = ? $or_empty_city $ornull )
5594 ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
5595 AND ( $table.${prefix}city = ? OR ? = '' OR CAST(? AS $text) IS NULL )
5596 AND ( $table.${prefix}county = ? $or_empty_county $ornull )
5597 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
5598 AND $table.${prefix}country = ?
5603 my( $self, $what ) = @_;
5605 my $what_show_zero = $what. '_show_zero';
5606 length($self->$what_show_zero())
5607 ? ($self->$what_show_zero() eq 'Y')
5608 : $self->part_pkg->$what_show_zero();
5615 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
5617 =item order \%PARAMS
5619 Bulk cancel + order subroutine. Perhaps slightly deprecated, only used by the
5620 bulk cancel+order in the web UI and nowhere else (edit/process/cust_pkg.cgi)
5622 CUSTNUM is a customer (see L<FS::cust_main>)
5624 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
5625 L<FS::part_pkg>) to order for this customer. Duplicates are of course
5628 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
5629 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
5630 new billing items. An error is returned if this is not possible (see
5631 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
5634 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
5635 newly-created cust_pkg objects.
5637 REFNUM, if specified, will specify the FS::pkg_referral record to be created
5638 and inserted. Multiple FS::pkg_referral records can be created by
5639 setting I<refnum> to an array reference of refnums or a hash reference with
5640 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
5641 record will be created corresponding to cust_main.refnum.
5643 LOCATIONNUM, if specified, will be set on newly created cust_pkg records
5648 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum,
5653 $custnum = $args->{custnum};
5654 $pkgparts = $args->{pkgparts};
5655 $remove_pkgnum = $args->{remove_pkgnum};
5656 $return_cust_pkg = $args->{return_cust_pkg};
5657 $refnum = $args->{refnum};
5658 $locationnum = $args->{locationnum};
5660 ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
5663 my $conf = new FS::Conf;
5665 # Transactionize this whole mess
5666 my $oldAutoCommit = $FS::UID::AutoCommit;
5667 local $FS::UID::AutoCommit = 0;
5671 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
5672 # return "Customer not found: $custnum" unless $cust_main;
5674 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
5677 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
5680 my $change = scalar(@old_cust_pkg) != 0;
5683 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
5685 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
5686 " to pkgpart ". $pkgparts->[0]. "\n"
5689 my $err_or_cust_pkg =
5690 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
5691 'refnum' => $refnum,
5694 unless (ref($err_or_cust_pkg)) {
5695 $dbh->rollback if $oldAutoCommit;
5696 return $err_or_cust_pkg;
5699 push @$return_cust_pkg, $err_or_cust_pkg;
5700 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5705 $hash{locationnum} = $locationnum if $locationnum;
5707 # Create the new packages.
5708 foreach my $pkgpart (@$pkgparts) {
5710 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
5712 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
5713 pkgpart => $pkgpart,
5717 $error = $cust_pkg->insert( 'change' => $change );
5718 push @$return_cust_pkg, $cust_pkg;
5720 foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
5721 my $supp_pkg = FS::cust_pkg->new({
5722 custnum => $custnum,
5723 pkgpart => $link->dst_pkgpart,
5725 main_pkgnum => $cust_pkg->pkgnum,
5728 $error ||= $supp_pkg->insert( 'change' => $change );
5729 push @$return_cust_pkg, $supp_pkg;
5733 $dbh->rollback if $oldAutoCommit;
5738 # $return_cust_pkg now contains refs to all of the newly
5741 # Transfer services and cancel old packages.
5742 foreach my $old_pkg (@old_cust_pkg) {
5744 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
5747 foreach my $new_pkg (@$return_cust_pkg) {
5748 $error = $old_pkg->transfer($new_pkg);
5749 if ($error and $error == 0) {
5750 # $old_pkg->transfer failed.
5751 $dbh->rollback if $oldAutoCommit;
5756 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
5757 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
5758 foreach my $new_pkg (@$return_cust_pkg) {
5759 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
5760 if ($error and $error == 0) {
5761 # $old_pkg->transfer failed.
5762 $dbh->rollback if $oldAutoCommit;
5769 # Transfers were successful, but we went through all of the
5770 # new packages and still had services left on the old package.
5771 # We can't cancel the package under the circumstances, so abort.
5772 $dbh->rollback if $oldAutoCommit;
5773 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
5775 $error = $old_pkg->cancel( quiet=>1, 'no_delay_cancel'=>1 );
5781 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5785 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
5787 A bulk change method to change packages for multiple customers.
5789 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
5790 L<FS::part_pkg>) to order for each customer. Duplicates are of course
5793 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
5794 replace. The services (see L<FS::cust_svc>) are moved to the
5795 new billing items. An error is returned if this is not possible (see
5798 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
5799 newly-created cust_pkg objects.
5804 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
5806 # Transactionize this whole mess
5807 my $oldAutoCommit = $FS::UID::AutoCommit;
5808 local $FS::UID::AutoCommit = 0;
5812 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
5815 while(scalar(@old_cust_pkg)) {
5817 my $custnum = $old_cust_pkg[0]->custnum;
5818 my (@remove) = map { $_->pkgnum }
5819 grep { $_->custnum == $custnum } @old_cust_pkg;
5820 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
5822 my $error = order $custnum, $pkgparts, \@remove, \@return;
5824 push @errors, $error
5826 push @$return_cust_pkg, @return;
5829 if (scalar(@errors)) {
5830 $dbh->rollback if $oldAutoCommit;
5831 return join(' / ', @errors);
5834 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5838 =item forward_emails
5840 Returns a hash of svcnums and corresponding email addresses
5841 for svc_acct services that can be used as source or dest
5842 for svc_forward services provisioned in this package.
5844 Accepts options I<svc_forward> OR I<svcnum> for a svc_forward
5845 service; if included, will ensure the current values of the
5846 specified service are included in the list, even if for some
5847 other reason they wouldn't be. If called as a class method
5848 with a specified service, returns only these current values.
5850 Caution: does not actually check if svc_forward services are
5851 available to be provisioned on this package.
5855 sub forward_emails {
5859 #load optional service, thoroughly validated
5860 die "Use svcnum or svc_forward, not both"
5861 if $opt{'svcnum'} && $opt{'svc_forward'};
5862 my $svc_forward = $opt{'svc_forward'};
5863 $svc_forward ||= qsearchs('svc_forward',{ 'svcnum' => $opt{'svcnum'} })
5865 die "Specified service is not a forward service"
5866 if $svc_forward && (ref($svc_forward) ne 'FS::svc_forward');
5867 die "Specified service not found"
5868 if ($opt{'svcnum'} || $opt{'svc_forward'}) && !$svc_forward;
5872 ## everything below was basically copied from httemplate/edit/svc_forward.cgi
5873 ## with minimal refactoring, not sure why we can't just load all svc_accts for this custnum
5875 #add current values from specified service, if there was one
5877 foreach my $method (qw( srcsvc_acct dstsvc_acct )) {
5878 my $svc_acct = $svc_forward->$method();
5879 $email{$svc_acct->svcnum} = $svc_acct->email if $svc_acct;
5883 if (ref($self) eq 'FS::cust_pkg') {
5885 #and including the rest for this customer
5886 my($u_part_svc,@u_acct_svcparts);
5887 foreach $u_part_svc ( qsearch('part_svc',{'svcdb'=>'svc_acct'}) ) {
5888 push @u_acct_svcparts,$u_part_svc->getfield('svcpart');
5891 my $custnum = $self->getfield('custnum');
5892 foreach my $i_cust_pkg ( qsearch('cust_pkg',{'custnum'=>$custnum}) ) {
5893 my $cust_pkgnum = $i_cust_pkg->getfield('pkgnum');
5894 #now find the corresponding record(s) in cust_svc (for this pkgnum!)
5895 foreach my $acct_svcpart (@u_acct_svcparts) {
5896 foreach my $i_cust_svc (
5897 qsearch( 'cust_svc', { 'pkgnum' => $cust_pkgnum,
5898 'svcpart' => $acct_svcpart } )
5900 my $svc_acct = qsearchs( 'svc_acct', { 'svcnum' => $i_cust_svc->svcnum } );
5901 $email{$svc_acct->svcnum} = $svc_acct->email;
5910 # Used by FS::Upgrade to migrate to a new database.
5911 sub _upgrade_schema { # class method
5912 my ($class, %opts) = @_;
5915 UPDATE cust_pkg SET change_to_pkgnum = NULL
5916 WHERE change_to_pkgnum IS NOT NULL
5917 AND NOT EXISTS ( SELECT 1 FROM cust_pkg AS ctcp
5918 WHERE ctcp.pkgnum = cust_pkg.change_to_pkgnum
5922 my $sth = dbh->prepare($sql) or die dbh->errstr;
5923 $sth->execute or die $sth->errstr;
5927 # Used by FS::Upgrade to migrate to a new database.
5928 sub _upgrade_data { # class method
5929 my ($class, %opts) = @_;
5930 $class->_upgrade_otaker(%opts);
5932 # RT#10139, bug resulting in contract_end being set when it shouldn't
5933 'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
5934 # RT#10830, bad calculation of prorate date near end of year
5935 # the date range for bill is December 2009, and we move it forward
5936 # one year if it's before the previous bill date (which it should
5938 'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
5939 AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
5940 WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
5941 # RT6628, add order_date to cust_pkg
5942 'update cust_pkg set order_date = (select history_date from h_cust_pkg
5943 where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
5944 history_action = \'insert\') where order_date is null',
5946 foreach my $sql (@statements) {
5947 my $sth = dbh->prepare($sql);
5948 $sth->execute or die $sth->errstr;
5951 # RT31194: supplemental package links that are deleted don't clean up
5953 my @pkglinknums = qsearch({
5954 'select' => 'DISTINCT cust_pkg.pkglinknum',
5955 'table' => 'cust_pkg',
5956 'addl_from' => ' LEFT JOIN part_pkg_link USING (pkglinknum) ',
5957 'extra_sql' => ' WHERE cust_pkg.pkglinknum IS NOT NULL
5958 AND part_pkg_link.pkglinknum IS NULL',
5960 foreach (@pkglinknums) {
5961 my $pkglinknum = $_->pkglinknum;
5962 warn "cleaning part_pkg_link #$pkglinknum\n";
5963 my $part_pkg_link = FS::part_pkg_link->new({pkglinknum => $pkglinknum});
5964 my $error = $part_pkg_link->remove_linked;
5965 die $error if $error;
5968 # RT#73607: canceling a package with billing addons sometimes changes its
5970 # Find records where the last replace_new record for the package before it
5971 # was canceled has a different pkgpart from the package itself.
5972 my @cust_pkg = qsearch({
5973 'table' => 'cust_pkg',
5974 'select' => 'cust_pkg.*, h_cust_pkg.pkgpart AS h_pkgpart',
5975 'addl_from' => ' JOIN (
5976 SELECT pkgnum, MAX(historynum) AS historynum FROM h_cust_pkg
5977 WHERE cancel IS NULL
5978 AND history_action = \'replace_new\'
5980 ) AS last_history USING (pkgnum)
5981 JOIN h_cust_pkg USING (historynum)',
5982 'extra_sql' => ' WHERE cust_pkg.cancel is not null
5983 AND cust_pkg.pkgpart != h_cust_pkg.pkgpart'
5985 foreach my $cust_pkg ( @cust_pkg ) {
5986 my $pkgnum = $cust_pkg->pkgnum;
5987 warn "fixing pkgpart on canceled pkg#$pkgnum\n";
5988 $cust_pkg->set('pkgpart', $cust_pkg->h_pkgpart);
5989 my $error = $cust_pkg->replace;
5990 die $error if $error;
5999 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
6001 In sub order, the @pkgparts array (passed by reference) is clobbered.
6003 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
6004 method to pass dates to the recur_prog expression, it should do so.
6006 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
6007 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
6008 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
6009 configuration values. Probably need a subroutine which decides what to do
6010 based on whether or not we've fetched the user yet, rather than a hash. See
6011 FS::UID and the TODO.
6013 Now that things are transactional should the check in the insert method be
6018 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
6019 L<FS::pkg_svc>, schema.html from the base documentation