4 use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::location_Mixin
5 FS::m2m_Common FS::option_Common );
6 use vars qw($disable_agentcheck $DEBUG $me);
8 use Scalar::Util qw( blessed );
9 use List::Util qw(max);
11 use Time::Local qw( timelocal timelocal_nocheck );
13 use FS::UID qw( getotaker dbh driver_name );
14 use FS::Misc qw( send_email );
15 use FS::Record qw( qsearch qsearchs fields );
20 use FS::cust_location;
22 use FS::cust_bill_pkg;
23 use FS::cust_pkg_detail;
28 use FS::cust_pkg_reason;
30 use FS::cust_pkg_discount;
35 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
37 # because they load configuration by setting FS::UID::callback (see TODO)
43 # for sending cancel emails in sub cancel
47 $me = '[FS::cust_pkg]';
49 $disable_agentcheck = 0;
53 my ( $hashref, $cache ) = @_;
54 #if ( $hashref->{'pkgpart'} ) {
55 if ( $hashref->{'pkg'} ) {
56 # #@{ $self->{'_pkgnum'} } = ();
57 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
58 # $self->{'_pkgpart'} = $subcache;
59 # #push @{ $self->{'_pkgnum'} },
60 # FS::part_pkg->new_or_cached($hashref, $subcache);
61 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
63 if ( exists $hashref->{'svcnum'} ) {
64 #@{ $self->{'_pkgnum'} } = ();
65 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
66 $self->{'_svcnum'} = $subcache;
67 #push @{ $self->{'_pkgnum'} },
68 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
74 FS::cust_pkg - Object methods for cust_pkg objects
80 $record = new FS::cust_pkg \%hash;
81 $record = new FS::cust_pkg { 'column' => 'value' };
83 $error = $record->insert;
85 $error = $new_record->replace($old_record);
87 $error = $record->delete;
89 $error = $record->check;
91 $error = $record->cancel;
93 $error = $record->suspend;
95 $error = $record->unsuspend;
97 $part_pkg = $record->part_pkg;
99 @labels = $record->labels;
101 $seconds = $record->seconds_since($timestamp);
103 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
104 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
108 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
109 inherits from FS::Record. The following fields are currently supported:
115 Primary key (assigned automatically for new billing items)
119 Customer (see L<FS::cust_main>)
123 Billing item definition (see L<FS::part_pkg>)
127 Optional link to package location (see L<FS::location>)
131 date package was ordered (also remains same on changes)
143 date (next bill date)
171 order taker (see L<FS::access_user>)
175 If this field is set to 1, disables the automatic
176 unsuspension of this package when using the B<unsuspendauto> config option.
180 If not set, defaults to 1
184 Date of change from previous package
194 =item change_locationnum
202 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
203 are specified as UNIX timestamps; see L<perlfunc/"time">. Also see
204 L<Time::Local> and L<Date::Parse> for conversion functions.
212 Create a new billing item. To add the item to the database, see L<"insert">.
216 sub table { 'cust_pkg'; }
217 sub cust_linked { $_[0]->cust_main_custnum; }
218 sub cust_unlinked_msg {
220 "WARNING: can't find cust_main.custnum ". $self->custnum.
221 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
224 =item insert [ OPTION => VALUE ... ]
226 Adds this billing item to the database ("Orders" the item). If there is an
227 error, returns the error, otherwise returns false.
229 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
230 will be used to look up the package definition and agent restrictions will be
233 If the additional field I<refnum> is defined, an FS::pkg_referral record will
234 be created and inserted. Multiple FS::pkg_referral records can be created by
235 setting I<refnum> to an array reference of refnums or a hash reference with
236 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
237 record will be created corresponding to cust_main.refnum.
239 The following options are available:
245 If set true, supresses actions that should only be taken for new package
246 orders. (Currently this includes: intro periods when delay_setup is on.)
250 cust_pkg_option records will be created
254 a ticket will be added to this customer with this subject
258 an optional queue name for ticket additions
265 my( $self, %options ) = @_;
267 my $error = $self->check_pkgpart;
268 return $error if $error;
270 my $part_pkg = $self->part_pkg;
272 if ( $part_pkg->option('start_1st', 1) && !$self->start_date ) {
273 my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
274 $mon += 1 unless $mday == 1;
275 until ( $mon < 12 ) { $mon -= 12; $year++; }
276 $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
279 foreach my $action ( qw(expire adjourn contract_end) ) {
280 my $months = $part_pkg->option("${action}_months",1);
281 if($months and !$self->$action) {
282 my $start = $self->start_date || $self->setup || time;
283 $self->$action( $part_pkg->add_freq($start, $months) );
287 if ( ! $options{'change'}
288 && ( my $free_days = $part_pkg->option('free_days',1) )
289 && $part_pkg->option('delay_setup',1)
290 #&& ! $self->start_date
293 my ($mday,$mon,$year) = (localtime(time) )[3,4,5];
294 #my $start_date = ($self->start_date || timelocal(0,0,0,$mday,$mon,$year)) + 86400 * $free_days;
295 my $start_date = timelocal(0,0,0,$mday,$mon,$year) + 86400 * $free_days;
296 $self->start_date($start_date);
299 $self->order_date(time);
301 local $SIG{HUP} = 'IGNORE';
302 local $SIG{INT} = 'IGNORE';
303 local $SIG{QUIT} = 'IGNORE';
304 local $SIG{TERM} = 'IGNORE';
305 local $SIG{TSTP} = 'IGNORE';
306 local $SIG{PIPE} = 'IGNORE';
308 my $oldAutoCommit = $FS::UID::AutoCommit;
309 local $FS::UID::AutoCommit = 0;
312 $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
314 $dbh->rollback if $oldAutoCommit;
318 $self->refnum($self->cust_main->refnum) unless $self->refnum;
319 $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
320 $self->process_m2m( 'link_table' => 'pkg_referral',
321 'target_table' => 'part_referral',
322 'params' => $self->refnum,
325 if ( $self->discountnum ) {
326 my $error = $self->insert_discount();
328 $dbh->rollback if $oldAutoCommit;
333 #if ( $self->reg_code ) {
334 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
335 # $error = $reg_code->delete;
337 # $dbh->rollback if $oldAutoCommit;
342 my $conf = new FS::Conf;
344 if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
347 # use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
354 use FS::TicketSystem;
355 FS::TicketSystem->init();
357 my $q = new RT::Queue($RT::SystemUser);
358 $q->Load($options{ticket_queue}) if $options{ticket_queue};
359 my $t = new RT::Ticket($RT::SystemUser);
360 my $mime = new MIME::Entity;
361 $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
362 $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
363 Subject => $options{ticket_subject},
366 $t->AddLink( Type => 'MemberOf',
367 Target => 'freeside://freeside/cust_main/'. $self->custnum,
371 if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
372 my $queue = new FS::queue {
373 'job' => 'FS::cust_main::queueable_print',
375 $error = $queue->insert(
376 'custnum' => $self->custnum,
377 'template' => 'welcome_letter',
381 warn "can't send welcome letter: $error";
386 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
393 This method now works but you probably shouldn't use it.
395 You don't want to delete packages, because there would then be no record
396 the customer ever purchased the package. Instead, see the cancel method and
397 hide cancelled packages.
404 local $SIG{HUP} = 'IGNORE';
405 local $SIG{INT} = 'IGNORE';
406 local $SIG{QUIT} = 'IGNORE';
407 local $SIG{TERM} = 'IGNORE';
408 local $SIG{TSTP} = 'IGNORE';
409 local $SIG{PIPE} = 'IGNORE';
411 my $oldAutoCommit = $FS::UID::AutoCommit;
412 local $FS::UID::AutoCommit = 0;
415 foreach my $cust_pkg_discount ($self->cust_pkg_discount) {
416 my $error = $cust_pkg_discount->delete;
418 $dbh->rollback if $oldAutoCommit;
422 #cust_bill_pkg_discount?
424 foreach my $cust_pkg_detail ($self->cust_pkg_detail) {
425 my $error = $cust_pkg_detail->delete;
427 $dbh->rollback if $oldAutoCommit;
432 foreach my $cust_pkg_reason (
434 'table' => 'cust_pkg_reason',
435 'hashref' => { 'pkgnum' => $self->pkgnum },
439 my $error = $cust_pkg_reason->delete;
441 $dbh->rollback if $oldAutoCommit;
448 my $error = $self->SUPER::delete(@_);
450 $dbh->rollback if $oldAutoCommit;
454 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
460 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
462 Replaces the OLD_RECORD with this one in the database. If there is an error,
463 returns the error, otherwise returns false.
465 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
467 Changing pkgpart may have disasterous effects. See the order subroutine.
469 setup and bill are normally updated by calling the bill method of a customer
470 object (see L<FS::cust_main>).
472 suspend is normally updated by the suspend and unsuspend methods.
474 cancel is normally updated by the cancel method (and also the order subroutine
477 Available options are:
483 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.
487 the access_user (see L<FS::access_user>) providing the reason
491 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
500 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
505 ( ref($_[0]) eq 'HASH' )
509 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
510 #return "Can't change otaker!" if $old->otaker ne $new->otaker;
513 #return "Can't change setup once it exists!"
514 # if $old->getfield('setup') &&
515 # $old->getfield('setup') != $new->getfield('setup');
517 #some logic for bill, susp, cancel?
519 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
521 local $SIG{HUP} = 'IGNORE';
522 local $SIG{INT} = 'IGNORE';
523 local $SIG{QUIT} = 'IGNORE';
524 local $SIG{TERM} = 'IGNORE';
525 local $SIG{TSTP} = 'IGNORE';
526 local $SIG{PIPE} = 'IGNORE';
528 my $oldAutoCommit = $FS::UID::AutoCommit;
529 local $FS::UID::AutoCommit = 0;
532 foreach my $method ( qw(adjourn expire) ) { # How many reasons?
533 if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
534 my $error = $new->insert_reason(
535 'reason' => $options->{'reason'},
536 'date' => $new->$method,
538 'reason_otaker' => $options->{'reason_otaker'},
541 dbh->rollback if $oldAutoCommit;
542 return "Error inserting cust_pkg_reason: $error";
547 #save off and freeze RADIUS attributes for any associated svc_acct records
549 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
551 #also check for specific exports?
552 # to avoid spurious modify export events
553 @svc_acct = map { $_->svc_x }
554 grep { $_->part_svc->svcdb eq 'svc_acct' }
557 $_->snapshot foreach @svc_acct;
561 my $error = $new->SUPER::replace($old,
562 $options->{options} ? $options->{options} : ()
565 $dbh->rollback if $oldAutoCommit;
569 #for prepaid packages,
570 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
571 foreach my $old_svc_acct ( @svc_acct ) {
572 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
574 $new_svc_acct->replace( $old_svc_acct,
575 'depend_jobnum' => $options->{depend_jobnum},
578 $dbh->rollback if $oldAutoCommit;
583 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
590 Checks all fields to make sure this is a valid billing item. If there is an
591 error, returns the error, otherwise returns false. Called by the insert and
599 $self->locationnum('') if !$self->locationnum || $self->locationnum == -1;
602 $self->ut_numbern('pkgnum')
603 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
604 || $self->ut_numbern('pkgpart')
605 || $self->check_pkgpart
606 || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
607 || $self->ut_numbern('start_date')
608 || $self->ut_numbern('setup')
609 || $self->ut_numbern('bill')
610 || $self->ut_numbern('susp')
611 || $self->ut_numbern('cancel')
612 || $self->ut_numbern('adjourn')
613 || $self->ut_numbern('resume')
614 || $self->ut_numbern('expire')
615 || $self->ut_numbern('dundate')
616 || $self->ut_enum('no_auto', [ '', 'Y' ])
617 || $self->ut_enum('waive_setup', [ '', 'Y' ])
618 || $self->ut_numbern('agent_pkgid')
619 || $self->ut_enum('recur_show_zero', [ '', 'Y', 'N', ])
620 || $self->ut_enum('setup_show_zero', [ '', 'Y', 'N', ])
622 return $error if $error;
624 return "A package with both start date (future start) and setup date (already started) will never bill"
625 if $self->start_date && $self->setup;
627 return "A future unsuspend date can only be set for a package with a suspend date"
628 if $self->resume and !$self->susp and !$self->adjourn;
630 $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
632 if ( $self->dbdef_table->column('manual_flag') ) {
633 $self->manual_flag('') if $self->manual_flag eq ' ';
634 $self->manual_flag =~ /^([01]?)$/
635 or return "Illegal manual_flag ". $self->manual_flag;
636 $self->manual_flag($1);
649 my $error = $self->ut_numbern('pkgpart');
650 return $error if $error;
652 if ( $self->reg_code ) {
654 unless ( grep { $self->pkgpart == $_->pkgpart }
655 map { $_->reg_code_pkg }
656 qsearchs( 'reg_code', { 'code' => $self->reg_code,
657 'agentnum' => $self->cust_main->agentnum })
659 return "Unknown registration code";
662 } elsif ( $self->promo_code ) {
665 qsearchs('part_pkg', {
666 'pkgpart' => $self->pkgpart,
667 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
669 return 'Unknown promotional code' unless $promo_part_pkg;
673 unless ( $disable_agentcheck ) {
675 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
676 return "agent ". $agent->agentnum. ':'. $agent->agent.
677 " can't purchase pkgpart ". $self->pkgpart
678 unless $agent->pkgpart_hashref->{ $self->pkgpart }
679 || $agent->agentnum == $self->part_pkg->agentnum;
682 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
683 return $error if $error;
691 =item cancel [ OPTION => VALUE ... ]
693 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
694 in this package, then cancels the package itself (sets the cancel field to
697 Available options are:
701 =item quiet - can be set true to supress email cancellation notices.
703 =item time - can be set to cancel the package based on a specific future or historical date. Using time ensures that the remaining amount is calculated correctly. Note however that this is an immediate cancel and just changes the date. You are PROBABLY looking to expire the account instead of using this.
705 =item reason - 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.
707 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
709 =item nobill - can be set true to skip billing if it might otherwise be done.
711 =item unused_credit - can be set to 1 to credit the remaining time, or 0 to
712 not credit it. This must be set (by change()) when changing the package
713 to a different pkgpart or location, and probably shouldn't be in any other
714 case. If it's not set, the 'unused_credit_cancel' part_pkg option will
719 If there is an error, returns the error, otherwise returns false.
724 my( $self, %options ) = @_;
727 my $conf = new FS::Conf;
729 warn "cust_pkg::cancel called with options".
730 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
733 local $SIG{HUP} = 'IGNORE';
734 local $SIG{INT} = 'IGNORE';
735 local $SIG{QUIT} = 'IGNORE';
736 local $SIG{TERM} = 'IGNORE';
737 local $SIG{TSTP} = 'IGNORE';
738 local $SIG{PIPE} = 'IGNORE';
740 my $oldAutoCommit = $FS::UID::AutoCommit;
741 local $FS::UID::AutoCommit = 0;
744 my $old = $self->select_for_update;
746 if ( $old->get('cancel') || $self->get('cancel') ) {
747 dbh->rollback if $oldAutoCommit;
748 return ""; # no error
751 my $date = $options{date} if $options{date}; # expire/cancel later
752 $date = '' if ($date && $date <= time); # complain instead?
754 #race condition: usage could be ongoing until unprovisioned
755 #resolved by performing a change package instead (which unprovisions) and
757 if ( !$options{nobill} && !$date && $conf->exists('bill_usage_on_cancel') ) {
758 my $copy = $self->new({$self->hash});
760 $copy->cust_main->bill( pkg_list => [ $copy ], cancel => 1 );
761 warn "Error billing during cancel, custnum ".
762 #$self->cust_main->custnum. ": $error"
767 my $cancel_time = $options{'time'} || time;
769 if ( $options{'reason'} ) {
770 $error = $self->insert_reason( 'reason' => $options{'reason'},
771 'action' => $date ? 'expire' : 'cancel',
772 'date' => $date ? $date : $cancel_time,
773 'reason_otaker' => $options{'reason_otaker'},
776 dbh->rollback if $oldAutoCommit;
777 return "Error inserting cust_pkg_reason: $error";
781 my %svc_cancel_opt = ();
782 $svc_cancel_opt{'date'} = $date if $date;
783 foreach my $cust_svc (
786 sort { $a->[1] <=> $b->[1] }
787 map { [ $_, $_->svc_x ? $_->svc_x->table_info->{'cancel_weight'} : -1 ]; }
788 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
790 my $part_svc = $cust_svc->part_svc;
791 next if ( defined($part_svc) and $part_svc->preserve );
792 my $error = $cust_svc->cancel( %svc_cancel_opt );
795 $dbh->rollback if $oldAutoCommit;
796 return 'Error '. ($svc_cancel_opt{'date'} ? 'expiring' : 'canceling' ).
803 # Add a credit for remaining service
804 my $last_bill = $self->getfield('last_bill') || 0;
805 my $next_bill = $self->getfield('bill') || 0;
807 if ( exists($options{'unused_credit'}) ) {
808 $do_credit = $options{'unused_credit'};
811 $do_credit = $self->part_pkg->option('unused_credit_cancel', 1);
814 and $last_bill > 0 # the package has been billed
815 and $next_bill > 0 # the package has a next bill date
816 and $next_bill >= $cancel_time # which is in the future
818 my $remaining_value = $self->calc_remain('time' => $cancel_time);
819 if ( $remaining_value > 0 ) {
820 my $error = $self->cust_main->credit(
822 'Credit for unused time on '. $self->part_pkg->pkg,
823 'reason_type' => $conf->config('cancel_credit_type'),
826 $dbh->rollback if $oldAutoCommit;
827 return "Error crediting customer \$$remaining_value for unused time".
828 " on ". $self->part_pkg->pkg. ": $error";
830 } #if $remaining_value
835 my %hash = $self->hash;
836 $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
837 my $new = new FS::cust_pkg ( \%hash );
838 $error = $new->replace( $self, options => { $self->options } );
840 $dbh->rollback if $oldAutoCommit;
844 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
845 return '' if $date; #no errors
847 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
848 if ( !$options{'quiet'} &&
849 $conf->exists('emailcancel', $self->cust_main->agentnum) &&
851 my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
854 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
855 $error = $msg_template->send( 'cust_main' => $self->cust_main,
860 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
861 'to' => \@invoicing_list,
862 'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
863 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
866 #should this do something on errors?
873 =item cancel_if_expired [ NOW_TIMESTAMP ]
875 Cancels this package if its expire date has been reached.
879 sub cancel_if_expired {
881 my $time = shift || time;
882 return '' unless $self->expire && $self->expire <= $time;
883 my $error = $self->cancel;
885 return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
886 $self->custnum. ": $error";
893 "Un-cancels" this package: Orders a new package with the same custnum, pkgpart,
894 locationnum, (other fields?). Attempts to re-provision cancelled services
895 using history information (errors at this stage are not fatal).
897 cust_pkg: pass a scalar reference, will be filled in with the new cust_pkg object
899 svc_fatal: service provisioning errors are fatal
901 svc_errors: pass an array reference, will be filled in with any provisioning errors
906 my( $self, %options ) = @_;
908 #in case you try do do $uncancel-date = $cust_pkg->uncacel
909 return '' unless $self->get('cancel');
915 local $SIG{HUP} = 'IGNORE';
916 local $SIG{INT} = 'IGNORE';
917 local $SIG{QUIT} = 'IGNORE';
918 local $SIG{TERM} = 'IGNORE';
919 local $SIG{TSTP} = 'IGNORE';
920 local $SIG{PIPE} = 'IGNORE';
922 my $oldAutoCommit = $FS::UID::AutoCommit;
923 local $FS::UID::AutoCommit = 0;
927 # insert the new package
930 my $cust_pkg = new FS::cust_pkg {
931 last_bill => ( $options{'last_bill'} || $self->get('last_bill') ),
932 bill => ( $options{'bill'} || $self->get('bill') ),
934 uncancel_pkgnum => $self->pkgnum,
935 map { $_ => $self->get($_) } qw(
936 custnum pkgpart locationnum
938 susp adjourn resume expire start_date contract_end dundate
939 change_date change_pkgpart change_locationnum
940 manual_flag no_auto quantity agent_pkgid recur_show_zero setup_show_zero
944 my $error = $cust_pkg->insert(
945 'change' => 1, #supresses any referral credit to a referring customer
948 $dbh->rollback if $oldAutoCommit;
956 #find historical services within this timeframe before the package cancel
957 # (incompatible with "time" option to cust_pkg->cancel?)
958 my $fuzz = 2 * 60; #2 minutes? too much? (might catch separate unprovision)
959 # too little? (unprovisioing export delay?)
960 my($end, $start) = ( $self->get('cancel'), $self->get('cancel') - $fuzz );
961 my @h_cust_svc = $self->h_cust_svc( $end, $start );
964 foreach my $h_cust_svc (@h_cust_svc) {
965 my $h_svc_x = $h_cust_svc->h_svc_x( $end, $start );
966 #next unless $h_svc_x; #should this happen?
967 (my $table = $h_svc_x->table) =~ s/^h_//;
968 require "FS/$table.pm";
969 my $class = "FS::$table";
970 my $svc_x = $class->new( {
971 'pkgnum' => $cust_pkg->pkgnum,
972 'svcpart' => $h_cust_svc->svcpart,
973 map { $_ => $h_svc_x->get($_) } fields($table)
977 if ( $h_svc_x->isa('FS::h_svc_Radius_Mixin') ) {
978 $svc_x->usergroup( [ $h_svc_x->h_usergroup($end, $start) ] );
981 my $svc_error = $svc_x->insert;
983 if ( $options{svc_fatal} ) {
984 $dbh->rollback if $oldAutoCommit;
987 # if we've failed to insert the svc_x object, svc_Common->insert
988 # will have removed the cust_svc already. if not, then both records
989 # were inserted but we failed for some other reason (export, most
990 # likely). in that case, report the error and delete the records.
991 push @svc_errors, $svc_error;
992 my $cust_svc = qsearchs('cust_svc', { 'svcnum' => $svc_x->svcnum });
994 # except if export_insert failed, export_delete probably won't be
996 local $FS::svc_Common::noexport_hack = 1;
997 my $cleanup_error = $svc_x->delete; # also deletes cust_svc
998 if ( $cleanup_error ) { # and if THAT fails, then run away
999 $dbh->rollback if $oldAutoCommit;
1000 return $cleanup_error;
1005 } #foreach $h_cust_svc
1007 #these are pretty rare, but should handle them
1008 # - dsl_device (mac addresses)
1009 # - phone_device (mac addresses)
1010 # - dsl_note (ikano notes)
1011 # - domain_record (i.e. restore DNS information w/domains)
1012 # - inventory_item(?) (inventory w/un-cancelling service?)
1013 # - nas (svc_broaband nas stuff)
1014 #this stuff is unused in the wild afaik
1015 # - mailinglistmember
1017 # - svc_domain.parent_svcnum?
1018 # - acct_snarf (ancient mail fetching config)
1019 # - cgp_rule (communigate)
1020 # - cust_svc_option (used by our Tron stuff)
1021 # - acct_rt_transaction (used by our time worked stuff)
1024 # also move over any services that didn't unprovision at cancellation
1027 foreach my $cust_svc ( qsearch('cust_svc', { pkgnum => $self->pkgnum } ) ) {
1028 $cust_svc->pkgnum( $cust_pkg->pkgnum );
1029 my $error = $cust_svc->replace;
1031 $dbh->rollback if $oldAutoCommit;
1040 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1042 ${ $options{cust_pkg} } = $cust_pkg if ref($options{cust_pkg});
1043 @{ $options{svc_errors} } = @svc_errors if ref($options{svc_errors});
1050 Cancels any pending expiration (sets the expire field to null).
1052 If there is an error, returns the error, otherwise returns false.
1057 my( $self, %options ) = @_;
1060 local $SIG{HUP} = 'IGNORE';
1061 local $SIG{INT} = 'IGNORE';
1062 local $SIG{QUIT} = 'IGNORE';
1063 local $SIG{TERM} = 'IGNORE';
1064 local $SIG{TSTP} = 'IGNORE';
1065 local $SIG{PIPE} = 'IGNORE';
1067 my $oldAutoCommit = $FS::UID::AutoCommit;
1068 local $FS::UID::AutoCommit = 0;
1071 my $old = $self->select_for_update;
1073 my $pkgnum = $old->pkgnum;
1074 if ( $old->get('cancel') || $self->get('cancel') ) {
1075 dbh->rollback if $oldAutoCommit;
1076 return "Can't unexpire cancelled package $pkgnum";
1077 # or at least it's pointless
1080 unless ( $old->get('expire') && $self->get('expire') ) {
1081 dbh->rollback if $oldAutoCommit;
1082 return ""; # no error
1085 my %hash = $self->hash;
1086 $hash{'expire'} = '';
1087 my $new = new FS::cust_pkg ( \%hash );
1088 $error = $new->replace( $self, options => { $self->options } );
1090 $dbh->rollback if $oldAutoCommit;
1094 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1100 =item suspend [ OPTION => VALUE ... ]
1102 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1103 package, then suspends the package itself (sets the susp field to now).
1105 Available options are:
1109 =item reason - can be set to a cancellation reason (see L<FS:reason>),
1110 either a reasonnum of an existing reason, or passing a hashref will create
1111 a new reason. The hashref should have the following keys:
1112 - typenum - Reason type (see L<FS::reason_type>
1113 - reason - Text of the new reason.
1115 =item date - can be set to a unix style timestamp to specify when to
1118 =item time - can be set to override the current time, for calculation
1119 of final invoices or unused-time credits
1121 =item resume_date - can be set to a time when the package should be
1122 unsuspended. This may be more convenient than calling C<unsuspend()>
1127 If there is an error, returns the error, otherwise returns false.
1132 my( $self, %options ) = @_;
1135 local $SIG{HUP} = 'IGNORE';
1136 local $SIG{INT} = 'IGNORE';
1137 local $SIG{QUIT} = 'IGNORE';
1138 local $SIG{TERM} = 'IGNORE';
1139 local $SIG{TSTP} = 'IGNORE';
1140 local $SIG{PIPE} = 'IGNORE';
1142 my $oldAutoCommit = $FS::UID::AutoCommit;
1143 local $FS::UID::AutoCommit = 0;
1146 my $old = $self->select_for_update;
1148 my $pkgnum = $old->pkgnum;
1149 if ( $old->get('cancel') || $self->get('cancel') ) {
1150 dbh->rollback if $oldAutoCommit;
1151 return "Can't suspend cancelled package $pkgnum";
1154 if ( $old->get('susp') || $self->get('susp') ) {
1155 dbh->rollback if $oldAutoCommit;
1156 return ""; # no error # complain on adjourn?
1159 my $suspend_time = $options{'time'} || time;
1161 my $date = $options{date} if $options{date}; # adjourn/suspend later
1162 $date = '' if ($date && $date <= $suspend_time); # complain instead?
1164 if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
1165 dbh->rollback if $oldAutoCommit;
1166 return "Package $pkgnum expires before it would be suspended.";
1169 if ( $options{'reason'} ) {
1170 $error = $self->insert_reason( 'reason' => $options{'reason'},
1171 'action' => $date ? 'adjourn' : 'suspend',
1172 'date' => $date ? $date : $suspend_time,
1173 'reason_otaker' => $options{'reason_otaker'},
1176 dbh->rollback if $oldAutoCommit;
1177 return "Error inserting cust_pkg_reason: $error";
1181 my %hash = $self->hash;
1183 $hash{'adjourn'} = $date;
1185 $hash{'susp'} = $suspend_time;
1188 my $resume_date = $options{'resume_date'} || 0;
1189 if ( $resume_date > ($date || $suspend_time) ) {
1190 $hash{'resume'} = $resume_date;
1193 $options{options} ||= {};
1195 my $new = new FS::cust_pkg ( \%hash );
1196 $error = $new->replace( $self, options => { $self->options,
1197 %{ $options{options} },
1201 $dbh->rollback if $oldAutoCommit;
1209 foreach my $cust_svc (
1210 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
1212 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1214 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1215 $dbh->rollback if $oldAutoCommit;
1216 return "Illegal svcdb value in part_svc!";
1219 require "FS/$svcdb.pm";
1221 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1223 $error = $svc->suspend;
1225 $dbh->rollback if $oldAutoCommit;
1228 my( $label, $value ) = $cust_svc->label;
1229 push @labels, "$label: $value";
1233 my $conf = new FS::Conf;
1234 if ( $conf->config('suspend_email_admin') ) {
1236 my $error = send_email(
1237 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1238 #invoice_from ??? well as good as any
1239 'to' => $conf->config('suspend_email_admin'),
1240 'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
1242 "This is an automatic message from your Freeside installation\n",
1243 "informing you that the following customer package has been suspended:\n",
1245 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1246 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1247 ( map { "Service : $_\n" } @labels ),
1252 warn "WARNING: can't send suspension admin email (suspending anyway): ".
1260 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1265 =item unsuspend [ OPTION => VALUE ... ]
1267 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1268 package, then unsuspends the package itself (clears the susp field and the
1269 adjourn field if it is in the past). If the suspend reason includes an
1270 unsuspension package, that package will be ordered.
1272 Available options are:
1278 Can be set to a date to unsuspend the package in the future (the 'resume'
1281 =item adjust_next_bill
1283 Can be set true to adjust the next bill date forward by
1284 the amount of time the account was inactive. This was set true by default
1285 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
1286 explicitly requested. Price plans for which this makes sense (anniversary-date
1287 based than prorate or subscription) could have an option to enable this
1292 If there is an error, returns the error, otherwise returns false.
1297 my( $self, %opt ) = @_;
1300 local $SIG{HUP} = 'IGNORE';
1301 local $SIG{INT} = 'IGNORE';
1302 local $SIG{QUIT} = 'IGNORE';
1303 local $SIG{TERM} = 'IGNORE';
1304 local $SIG{TSTP} = 'IGNORE';
1305 local $SIG{PIPE} = 'IGNORE';
1307 my $oldAutoCommit = $FS::UID::AutoCommit;
1308 local $FS::UID::AutoCommit = 0;
1311 my $old = $self->select_for_update;
1313 my $pkgnum = $old->pkgnum;
1314 if ( $old->get('cancel') || $self->get('cancel') ) {
1315 $dbh->rollback if $oldAutoCommit;
1316 return "Can't unsuspend cancelled package $pkgnum";
1319 unless ( $old->get('susp') && $self->get('susp') ) {
1320 $dbh->rollback if $oldAutoCommit;
1321 return ""; # no error # complain instead?
1324 my $date = $opt{'date'};
1325 if ( $date and $date > time ) { # return an error if $date <= time?
1327 if ( $old->get('expire') && $old->get('expire') < $date ) {
1328 $dbh->rollback if $oldAutoCommit;
1329 return "Package $pkgnum expires before it would be unsuspended.";
1332 my $new = new FS::cust_pkg { $self->hash };
1333 $new->set('resume', $date);
1334 $error = $new->replace($self, options => $self->options);
1337 $dbh->rollback if $oldAutoCommit;
1341 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1349 foreach my $cust_svc (
1350 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1352 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1354 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1355 $dbh->rollback if $oldAutoCommit;
1356 return "Illegal svcdb value in part_svc!";
1359 require "FS/$svcdb.pm";
1361 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1363 $error = $svc->unsuspend;
1365 $dbh->rollback if $oldAutoCommit;
1368 my( $label, $value ) = $cust_svc->label;
1369 push @labels, "$label: $value";
1374 my $cust_pkg_reason = $self->last_cust_pkg_reason('susp');
1375 my $reason = $cust_pkg_reason ? $cust_pkg_reason->reason : '';
1377 my %hash = $self->hash;
1378 my $inactive = time - $hash{'susp'};
1380 my $conf = new FS::Conf;
1382 if ( $inactive > 0 &&
1383 ( $hash{'bill'} || $hash{'setup'} ) &&
1384 ( $opt{'adjust_next_bill'} ||
1385 $conf->exists('unsuspend-always_adjust_next_bill_date') ||
1386 $self->part_pkg->option('unsuspend_adjust_bill', 1) )
1389 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
1394 $hash{'adjourn'} = '' if $hash{'adjourn'} and $hash{'adjourn'} < time;
1395 $hash{'resume'} = '' if !$hash{'adjourn'};
1396 my $new = new FS::cust_pkg ( \%hash );
1397 $error = $new->replace( $self, options => { $self->options } );
1399 $dbh->rollback if $oldAutoCommit;
1405 if ( $reason && $reason->unsuspend_pkgpart ) {
1406 my $part_pkg = FS::part_pkg->by_key($reason->unsuspend_pkgpart)
1407 or $error = "Unsuspend package definition ".$reason->unsuspend_pkgpart.
1409 my $start_date = $self->cust_main->next_bill_date
1410 if $reason->unsuspend_hold;
1413 $unsusp_pkg = FS::cust_pkg->new({
1414 'custnum' => $self->custnum,
1415 'pkgpart' => $reason->unsuspend_pkgpart,
1416 'start_date' => $start_date,
1417 'locationnum' => $self->locationnum,
1418 # discount? probably not...
1421 $error ||= $self->cust_main->order_pkg( 'cust_pkg' => $unsusp_pkg );
1425 $dbh->rollback if $oldAutoCommit;
1430 if ( $conf->config('unsuspend_email_admin') ) {
1432 my $error = send_email(
1433 'from' => $conf->config('invoice_from', $self->cust_main->agentnum),
1434 #invoice_from ??? well as good as any
1435 'to' => $conf->config('unsuspend_email_admin'),
1436 'subject' => 'FREESIDE NOTIFICATION: Customer package unsuspended', 'body' => [
1437 "This is an automatic message from your Freeside installation\n",
1438 "informing you that the following customer package has been unsuspended:\n",
1440 'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1441 'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1442 ( map { "Service : $_\n" } @labels ),
1444 "An unsuspension fee was charged: ".
1445 $unsusp_pkg->part_pkg->pkg_comment."\n"
1452 warn "WARNING: can't send unsuspension admin email (unsuspending anyway): ".
1458 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1465 Cancels any pending suspension (sets the adjourn field to null).
1467 If there is an error, returns the error, otherwise returns false.
1472 my( $self, %options ) = @_;
1475 local $SIG{HUP} = 'IGNORE';
1476 local $SIG{INT} = 'IGNORE';
1477 local $SIG{QUIT} = 'IGNORE';
1478 local $SIG{TERM} = 'IGNORE';
1479 local $SIG{TSTP} = 'IGNORE';
1480 local $SIG{PIPE} = 'IGNORE';
1482 my $oldAutoCommit = $FS::UID::AutoCommit;
1483 local $FS::UID::AutoCommit = 0;
1486 my $old = $self->select_for_update;
1488 my $pkgnum = $old->pkgnum;
1489 if ( $old->get('cancel') || $self->get('cancel') ) {
1490 dbh->rollback if $oldAutoCommit;
1491 return "Can't unadjourn cancelled package $pkgnum";
1492 # or at least it's pointless
1495 if ( $old->get('susp') || $self->get('susp') ) {
1496 dbh->rollback if $oldAutoCommit;
1497 return "Can't unadjourn suspended package $pkgnum";
1498 # perhaps this is arbitrary
1501 unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1502 dbh->rollback if $oldAutoCommit;
1503 return ""; # no error
1506 my %hash = $self->hash;
1507 $hash{'adjourn'} = '';
1508 $hash{'resume'} = '';
1509 my $new = new FS::cust_pkg ( \%hash );
1510 $error = $new->replace( $self, options => { $self->options } );
1512 $dbh->rollback if $oldAutoCommit;
1516 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1523 =item change HASHREF | OPTION => VALUE ...
1525 Changes this package: cancels it and creates a new one, with a different
1526 pkgpart or locationnum or both. All services are transferred to the new
1527 package (no change will be made if this is not possible).
1529 Options may be passed as a list of key/value pairs or as a hash reference.
1536 New locationnum, to change the location for this package.
1540 New FS::cust_location object, to create a new location and assign it
1545 New pkgpart (see L<FS::part_pkg>).
1549 New refnum (see L<FS::part_referral>).
1553 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
1554 susp, adjourn, cancel, expire, and contract_end) to the new package.
1558 At least one of locationnum, cust_location, pkgpart, refnum must be specified
1559 (otherwise, what's the point?)
1561 Returns either the new FS::cust_pkg object or a scalar error.
1565 my $err_or_new_cust_pkg = $old_cust_pkg->change
1569 #some false laziness w/order
1572 my $opt = ref($_[0]) ? shift : { @_ };
1574 # my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1577 my $conf = new FS::Conf;
1579 # Transactionize this whole mess
1580 local $SIG{HUP} = 'IGNORE';
1581 local $SIG{INT} = 'IGNORE';
1582 local $SIG{QUIT} = 'IGNORE';
1583 local $SIG{TERM} = 'IGNORE';
1584 local $SIG{TSTP} = 'IGNORE';
1585 local $SIG{PIPE} = 'IGNORE';
1587 my $oldAutoCommit = $FS::UID::AutoCommit;
1588 local $FS::UID::AutoCommit = 0;
1597 #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1599 #$hash{$_} = $self->$_() foreach qw( setup );
1601 $hash{'setup'} = $time if $self->setup;
1603 $hash{'change_date'} = $time;
1604 $hash{"change_$_"} = $self->$_()
1605 foreach qw( pkgnum pkgpart locationnum );
1607 if ( $opt->{'cust_location'} &&
1608 ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1609 $error = $opt->{'cust_location'}->insert;
1611 $dbh->rollback if $oldAutoCommit;
1612 return "inserting cust_location (transaction rolled back): $error";
1614 $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1617 my $unused_credit = 0;
1618 if ( $opt->{'keep_dates'} ) {
1619 foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1620 resume start_date contract_end ) ) {
1621 $hash{$date} = $self->getfield($date);
1624 # Special case. If the pkgpart is changing, and the customer is
1625 # going to be credited for remaining time, don't keep setup, bill,
1626 # or last_bill dates, and DO pass the flag to cancel() to credit
1628 if ( $opt->{'pkgpart'}
1629 and $opt->{'pkgpart'} != $self->pkgpart
1630 and $self->part_pkg->option('unused_credit_change', 1) ) {
1632 $hash{$_} = '' foreach qw(setup bill last_bill);
1635 # allow $opt->{'locationnum'} = '' to specifically set it to null
1636 # (i.e. customer default location)
1637 $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
1639 # Create the new package.
1640 my $cust_pkg = new FS::cust_pkg {
1641 custnum => $self->custnum,
1642 pkgpart => ( $opt->{'pkgpart'} || $self->pkgpart ),
1643 refnum => ( $opt->{'refnum'} || $self->refnum ),
1644 locationnum => ( $opt->{'locationnum'} ),
1648 $error = $cust_pkg->insert( 'change' => 1 );
1650 $dbh->rollback if $oldAutoCommit;
1654 # Transfer services and cancel old package.
1656 $error = $self->transfer($cust_pkg);
1657 if ($error and $error == 0) {
1658 # $old_pkg->transfer failed.
1659 $dbh->rollback if $oldAutoCommit;
1663 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1664 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1665 $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1666 if ($error and $error == 0) {
1667 # $old_pkg->transfer failed.
1668 $dbh->rollback if $oldAutoCommit;
1674 # Transfers were successful, but we still had services left on the old
1675 # package. We can't change the package under this circumstances, so abort.
1676 $dbh->rollback if $oldAutoCommit;
1677 return "Unable to transfer all services from package ". $self->pkgnum;
1680 #reset usage if changing pkgpart
1681 # AND usage rollover is off (otherwise adds twice, now and at package bill)
1682 if ($self->pkgpart != $cust_pkg->pkgpart) {
1683 my $part_pkg = $cust_pkg->part_pkg;
1684 $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1688 if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
1691 $dbh->rollback if $oldAutoCommit;
1692 return "Error setting usage values: $error";
1696 #Good to go, cancel old package. Notify 'cancel' of whether to credit
1698 $error = $self->cancel( quiet=>1, unused_credit => $unused_credit );
1700 $dbh->rollback if $oldAutoCommit;
1704 if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1706 my $error = $cust_pkg->cust_main->bill( 'pkg_list' => [ $cust_pkg ] );
1708 $dbh->rollback if $oldAutoCommit;
1713 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1719 use Storable 'thaw';
1721 sub process_bulk_cust_pkg {
1723 my $param = thaw(decode_base64(shift));
1724 warn Dumper($param) if $DEBUG;
1726 my $old_part_pkg = qsearchs('part_pkg',
1727 { pkgpart => $param->{'old_pkgpart'} });
1728 my $new_part_pkg = qsearchs('part_pkg',
1729 { pkgpart => $param->{'new_pkgpart'} });
1730 die "Must select a new package type\n" unless $new_part_pkg;
1731 #my $keep_dates = $param->{'keep_dates'} || 0;
1732 my $keep_dates = 1; # there is no good reason to turn this off
1734 local $SIG{HUP} = 'IGNORE';
1735 local $SIG{INT} = 'IGNORE';
1736 local $SIG{QUIT} = 'IGNORE';
1737 local $SIG{TERM} = 'IGNORE';
1738 local $SIG{TSTP} = 'IGNORE';
1739 local $SIG{PIPE} = 'IGNORE';
1741 my $oldAutoCommit = $FS::UID::AutoCommit;
1742 local $FS::UID::AutoCommit = 0;
1745 my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
1748 foreach my $old_cust_pkg ( @cust_pkgs ) {
1750 $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
1751 if ( $old_cust_pkg->getfield('cancel') ) {
1752 warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
1753 $old_cust_pkg->pkgnum."\n"
1757 warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
1759 my $error = $old_cust_pkg->change(
1760 'pkgpart' => $param->{'new_pkgpart'},
1761 'keep_dates' => $keep_dates
1763 if ( !ref($error) ) { # change returns the cust_pkg on success
1765 die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
1768 $dbh->commit if $oldAutoCommit;
1774 Returns the last bill date, or if there is no last bill date, the setup date.
1775 Useful for billing metered services.
1781 return $self->setfield('last_bill', $_[0]) if @_;
1782 return $self->getfield('last_bill') if $self->getfield('last_bill');
1783 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1784 'edate' => $self->bill, } );
1785 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1788 =item last_cust_pkg_reason ACTION
1790 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1791 Returns false if there is no reason or the package is not currenly ACTION'd
1792 ACTION is one of adjourn, susp, cancel, or expire.
1796 sub last_cust_pkg_reason {
1797 my ( $self, $action ) = ( shift, shift );
1798 my $date = $self->get($action);
1800 'table' => 'cust_pkg_reason',
1801 'hashref' => { 'pkgnum' => $self->pkgnum,
1802 'action' => substr(uc($action), 0, 1),
1805 'order_by' => 'ORDER BY num DESC LIMIT 1',
1809 =item last_reason ACTION
1811 Returns the most recent ACTION FS::reason associated with the package.
1812 Returns false if there is no reason or the package is not currenly ACTION'd
1813 ACTION is one of adjourn, susp, cancel, or expire.
1818 my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1819 $cust_pkg_reason->reason
1820 if $cust_pkg_reason;
1825 Returns the definition for this billing item, as an FS::part_pkg object (see
1832 return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1833 cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1834 qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1839 Returns the cancelled package this package was changed from, if any.
1845 return '' unless $self->change_pkgnum;
1846 qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1851 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1858 $self->part_pkg->calc_setup($self, @_);
1863 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1870 $self->part_pkg->calc_recur($self, @_);
1875 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
1882 $self->part_pkg->base_recur($self, @_);
1887 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1894 $self->part_pkg->calc_remain($self, @_);
1899 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1906 $self->part_pkg->calc_cancel($self, @_);
1911 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1917 qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1920 =item cust_pkg_detail [ DETAILTYPE ]
1922 Returns any customer package details for this package (see
1923 L<FS::cust_pkg_detail>).
1925 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1929 sub cust_pkg_detail {
1931 my %hash = ( 'pkgnum' => $self->pkgnum );
1932 $hash{detailtype} = shift if @_;
1934 'table' => 'cust_pkg_detail',
1935 'hashref' => \%hash,
1936 'order_by' => 'ORDER BY weight, pkgdetailnum',
1940 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1942 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1944 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1946 If there is an error, returns the error, otherwise returns false.
1950 sub set_cust_pkg_detail {
1951 my( $self, $detailtype, @details ) = @_;
1953 local $SIG{HUP} = 'IGNORE';
1954 local $SIG{INT} = 'IGNORE';
1955 local $SIG{QUIT} = 'IGNORE';
1956 local $SIG{TERM} = 'IGNORE';
1957 local $SIG{TSTP} = 'IGNORE';
1958 local $SIG{PIPE} = 'IGNORE';
1960 my $oldAutoCommit = $FS::UID::AutoCommit;
1961 local $FS::UID::AutoCommit = 0;
1964 foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1965 my $error = $current->delete;
1967 $dbh->rollback if $oldAutoCommit;
1968 return "error removing old detail: $error";
1972 foreach my $detail ( @details ) {
1973 my $cust_pkg_detail = new FS::cust_pkg_detail {
1974 'pkgnum' => $self->pkgnum,
1975 'detailtype' => $detailtype,
1976 'detail' => $detail,
1978 my $error = $cust_pkg_detail->insert;
1980 $dbh->rollback if $oldAutoCommit;
1981 return "error adding new detail: $error";
1986 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1993 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1997 #false laziness w/cust_bill.pm
2001 'table' => 'cust_event',
2002 'addl_from' => 'JOIN part_event USING ( eventpart )',
2003 'hashref' => { 'tablenum' => $self->pkgnum },
2004 'extra_sql' => " AND eventtable = 'cust_pkg' ",
2008 =item num_cust_event
2010 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
2014 #false laziness w/cust_bill.pm
2015 sub num_cust_event {
2018 "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
2019 " WHERE tablenum = ? AND eventtable = 'cust_pkg'";
2020 my $sth = dbh->prepare($sql) or die dbh->errstr. " preparing $sql";
2021 $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
2022 $sth->fetchrow_arrayref->[0];
2025 =item cust_svc [ SVCPART ] (old, deprecated usage)
2027 =item cust_svc [ OPTION => VALUE ... ] (current usage)
2029 Returns the services for this package, as FS::cust_svc objects (see
2030 L<FS::cust_svc>). Available options are svcpart and svcdb. If either is
2031 spcififed, returns only the matching services.
2038 return () unless $self->num_cust_svc(@_);
2041 if ( @_ && $_[0] =~ /^\d+/ ) {
2042 $opt{svcpart} = shift;
2043 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2050 'table' => 'cust_svc',
2051 'hashref' => { 'pkgnum' => $self->pkgnum },
2053 if ( $opt{svcpart} ) {
2054 $search{hashref}->{svcpart} = $opt{'svcpart'};
2056 if ( $opt{'svcdb'} ) {
2057 $search{addl_from} = ' LEFT JOIN part_svc USING ( svcpart ) ';
2058 $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{'svcdb'} );
2061 cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
2063 #if ( $self->{'_svcnum'} ) {
2064 # values %{ $self->{'_svcnum'}->cache };
2066 $self->_sort_cust_svc( [ qsearch(\%search) ] );
2071 =item overlimit [ SVCPART ]
2073 Returns the services for this package which have exceeded their
2074 usage limit as FS::cust_svc objects (see L<FS::cust_svc>). If a svcpart
2075 is specified, return only the matching services.
2081 return () unless $self->num_cust_svc(@_);
2082 grep { $_->overlimit } $self->cust_svc(@_);
2085 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2087 Returns historical services for this package created before END TIMESTAMP and
2088 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
2089 (see L<FS::h_cust_svc>). If MODE is 'I' (for 'invoice'), services with the
2090 I<pkg_svc.hidden> flag will be omitted.
2096 warn "$me _h_cust_svc called on $self\n"
2099 my ($end, $start, $mode) = @_;
2100 my @cust_svc = $self->_sort_cust_svc(
2101 [ qsearch( 'h_cust_svc',
2102 { 'pkgnum' => $self->pkgnum, },
2103 FS::h_cust_svc->sql_h_search(@_),
2106 if ( defined($mode) && $mode eq 'I' ) {
2107 my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
2108 return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
2114 sub _sort_cust_svc {
2115 my( $self, $arrayref ) = @_;
2118 sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] };
2123 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
2124 'svcpart' => $_->svcpart } );
2126 $pkg_svc ? $pkg_svc->primary_svc : '',
2127 $pkg_svc ? $pkg_svc->quantity : 0,
2134 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
2136 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
2138 Returns the number of services for this package. Available options are svcpart
2139 and svcdb. If either is spcififed, returns only the matching services.
2146 return $self->{'_num_cust_svc'}
2148 && exists($self->{'_num_cust_svc'})
2149 && $self->{'_num_cust_svc'} =~ /\d/;
2151 cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
2155 if ( @_ && $_[0] =~ /^\d+/ ) {
2156 $opt{svcpart} = shift;
2157 } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2163 my $select = 'SELECT COUNT(*) FROM cust_svc ';
2164 my $where = ' WHERE pkgnum = ? ';
2165 my @param = ($self->pkgnum);
2167 if ( $opt{'svcpart'} ) {
2168 $where .= ' AND svcpart = ? ';
2169 push @param, $opt{'svcpart'};
2171 if ( $opt{'svcdb'} ) {
2172 $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
2173 $where .= ' AND svcdb = ? ';
2174 push @param, $opt{'svcdb'};
2177 my $sth = dbh->prepare("$select $where") or die dbh->errstr;
2178 $sth->execute(@param) or die $sth->errstr;
2179 $sth->fetchrow_arrayref->[0];
2182 =item available_part_svc
2184 Returns a list of FS::part_svc objects representing services included in this
2185 package but not yet provisioned. Each FS::part_svc object also has an extra
2186 field, I<num_avail>, which specifies the number of available services.
2190 sub available_part_svc {
2192 grep { $_->num_avail > 0 }
2194 my $part_svc = $_->part_svc;
2195 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
2196 $_->quantity - $self->num_cust_svc($_->svcpart);
2198 # more evil encapsulation breakage
2199 if($part_svc->{'Hash'}{'num_avail'} > 0) {
2200 my @exports = $part_svc->part_export_did;
2201 $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
2206 $self->part_pkg->pkg_svc;
2209 =item part_svc [ OPTION => VALUE ... ]
2211 Returns a list of FS::part_svc objects representing provisioned and available
2212 services included in this package. Each FS::part_svc object also has the
2213 following extra fields:
2217 =item num_cust_svc (count)
2219 =item num_avail (quantity - count)
2221 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
2225 Accepts one option: summarize_size. If specified and non-zero, will omit the
2226 extra cust_pkg_svc option for objects where num_cust_svc is this size or
2232 #label -> ($cust_svc->label)[1]
2238 #XXX some sort of sort order besides numeric by svcpart...
2239 my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
2241 my $part_svc = $pkg_svc->part_svc;
2242 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2243 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
2244 $part_svc->{'Hash'}{'num_avail'} =
2245 max( 0, $pkg_svc->quantity - $num_cust_svc );
2246 $part_svc->{'Hash'}{'cust_pkg_svc'} =
2247 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
2248 unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
2249 && $num_cust_svc >= $opt{summarize_size};
2250 $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
2252 } $self->part_pkg->pkg_svc;
2255 push @part_svc, map {
2257 my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2258 $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
2259 $part_svc->{'Hash'}{'num_avail'} = 0; #0-$num_cust_svc ?
2260 $part_svc->{'Hash'}{'cust_pkg_svc'} =
2261 $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
2263 } $self->extra_part_svc;
2269 =item extra_part_svc
2271 Returns a list of FS::part_svc objects corresponding to services in this
2272 package which are still provisioned but not (any longer) available in the
2277 sub extra_part_svc {
2280 my $pkgnum = $self->pkgnum;
2281 #my $pkgpart = $self->pkgpart;
2284 # 'table' => 'part_svc',
2287 # "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
2288 # WHERE pkg_svc.svcpart = part_svc.svcpart
2289 # AND pkg_svc.pkgpart = ?
2292 # AND 0 < ( SELECT COUNT(*) FROM cust_svc
2293 # LEFT JOIN cust_pkg USING ( pkgnum )
2294 # WHERE cust_svc.svcpart = part_svc.svcpart
2297 # 'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
2300 #seems to benchmark slightly faster... (or did?)
2302 my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
2303 my $pkgparts = join(',', @pkgparts);
2306 #'select' => 'DISTINCT ON (svcpart) part_svc.*',
2307 #MySQL doesn't grok DISINCT ON
2308 'select' => 'DISTINCT part_svc.*',
2309 'table' => 'part_svc',
2311 "LEFT JOIN pkg_svc ON ( pkg_svc.svcpart = part_svc.svcpart
2312 AND pkg_svc.pkgpart IN ($pkgparts)
2315 LEFT JOIN cust_svc ON ( cust_svc.svcpart = part_svc.svcpart )
2316 LEFT JOIN cust_pkg USING ( pkgnum )
2319 'extra_sql' => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
2320 'extra_param' => [ [$self->pkgnum=>'int'] ],
2326 Returns a short status string for this package, currently:
2330 =item not yet billed
2332 =item one-time charge
2347 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
2349 return 'cancelled' if $self->get('cancel');
2350 return 'suspended' if $self->susp;
2351 return 'not yet billed' unless $self->setup;
2352 return 'one-time charge' if $freq =~ /^(0|$)/;
2356 =item ucfirst_status
2358 Returns the status with the first character capitalized.
2362 sub ucfirst_status {
2363 ucfirst(shift->status);
2368 Class method that returns the list of possible status strings for packages
2369 (see L<the status method|/status>). For example:
2371 @statuses = FS::cust_pkg->statuses();
2375 tie my %statuscolor, 'Tie::IxHash',
2376 'not yet billed' => '009999', #teal? cyan?
2377 'one-time charge' => '000000',
2378 'active' => '00CC00',
2379 'suspended' => 'FF9900',
2380 'cancelled' => 'FF0000',
2384 my $self = shift; #could be class...
2385 #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
2386 # # mayble split btw one-time vs. recur
2392 Returns a hex triplet color string for this package's status.
2398 $statuscolor{$self->status};
2403 Returns a label for this package. (Currently "pkgnum: pkg - comment" or
2404 "pkg-comment" depending on user preference).
2410 my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
2411 $label = $self->pkgnum. ": $label"
2412 if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
2416 =item pkg_label_long
2418 Returns a long label for this package, adding the primary service's label to
2423 sub pkg_label_long {
2425 my $label = $self->pkg_label;
2426 my $cust_svc = $self->primary_cust_svc;
2427 $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
2431 =item primary_cust_svc
2433 Returns a primary service (as FS::cust_svc object) if one can be identified.
2437 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
2439 sub primary_cust_svc {
2442 my @cust_svc = $self->cust_svc;
2444 return '' unless @cust_svc; #no serivces - irrelevant then
2446 return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
2448 # primary service as specified in the package definition
2449 # or exactly one service definition with quantity one
2450 my $svcpart = $self->part_pkg->svcpart;
2451 @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
2452 return $cust_svc[0] if scalar(@cust_svc) == 1;
2454 #couldn't identify one thing..
2460 Returns a list of lists, calling the label method for all services
2461 (see L<FS::cust_svc>) of this billing item.
2467 map { [ $_->label ] } $self->cust_svc;
2470 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2472 Like the labels method, but returns historical information on services that
2473 were active as of END_TIMESTAMP and (optionally) not cancelled before
2474 START_TIMESTAMP. If MODE is 'I' (for 'invoice'), services with the
2475 I<pkg_svc.hidden> flag will be omitted.
2477 Returns a list of lists, calling the label method for all (historical) services
2478 (see L<FS::h_cust_svc>) of this billing item.
2484 warn "$me _h_labels called on $self\n"
2486 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
2491 Like labels, except returns a simple flat list, and shortens long
2492 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2493 identical services to one line that lists the service label and the number of
2494 individual services rather than individual items.
2499 shift->_labels_short( 'labels', @_ );
2502 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
2504 Like h_labels, except returns a simple flat list, and shortens long
2505 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2506 identical services to one line that lists the service label and the number of
2507 individual services rather than individual items.
2511 sub h_labels_short {
2512 shift->_labels_short( 'h_labels', @_ );
2516 my( $self, $method ) = ( shift, shift );
2518 warn "$me _labels_short called on $self with $method method\n"
2521 my $conf = new FS::Conf;
2522 my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
2524 warn "$me _labels_short populating \%labels\n"
2528 #tie %labels, 'Tie::IxHash';
2529 push @{ $labels{$_->[0]} }, $_->[1]
2530 foreach $self->$method(@_);
2532 warn "$me _labels_short populating \@labels\n"
2536 foreach my $label ( keys %labels ) {
2538 my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
2539 my $num = scalar(@values);
2540 warn "$me _labels_short $num items for $label\n"
2543 if ( $num > $max_same_services ) {
2544 warn "$me _labels_short more than $max_same_services, so summarizing\n"
2546 push @labels, "$label ($num)";
2548 if ( $conf->exists('cust_bill-consolidate_services') ) {
2549 warn "$me _labels_short consolidating services\n"
2551 # push @labels, "$label: ". join(', ', @values);
2553 my $detail = "$label: ";
2554 $detail .= shift(@values). ', '
2556 && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
2558 push @labels, $detail;
2560 warn "$me _labels_short done consolidating services\n"
2563 warn "$me _labels_short adding service data\n"
2565 push @labels, map { "$label: $_" } @values;
2576 Returns the parent customer object (see L<FS::cust_main>).
2582 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
2587 Returns the balance for this specific package, when using
2588 experimental package balance.
2594 $self->cust_main->balance_pkgnum( $self->pkgnum );
2597 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
2601 Returns the location object, if any (see L<FS::cust_location>).
2603 =item cust_location_or_main
2605 If this package is associated with a location, returns the locaiton (see
2606 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
2608 =item location_label [ OPTION => VALUE ... ]
2610 Returns the label of the location object (see L<FS::cust_location>).
2614 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2616 =item seconds_since TIMESTAMP
2618 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2619 package have been online since TIMESTAMP, according to the session monitor.
2621 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2622 L<Time::Local> and L<Date::Parse> for conversion functions.
2627 my($self, $since) = @_;
2630 foreach my $cust_svc (
2631 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2633 $seconds += $cust_svc->seconds_since($since);
2640 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2642 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2643 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2646 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2647 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2653 sub seconds_since_sqlradacct {
2654 my($self, $start, $end) = @_;
2658 foreach my $cust_svc (
2660 my $part_svc = $_->part_svc;
2661 $part_svc->svcdb eq 'svc_acct'
2662 && scalar($part_svc->part_export_usage);
2665 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2672 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2674 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2675 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2679 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2680 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2685 sub attribute_since_sqlradacct {
2686 my($self, $start, $end, $attrib) = @_;
2690 foreach my $cust_svc (
2692 my $part_svc = $_->part_svc;
2693 $part_svc->svcdb eq 'svc_acct'
2694 && scalar($part_svc->part_export_usage);
2697 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2709 my( $self, $value ) = @_;
2710 if ( defined($value) ) {
2711 $self->setfield('quantity', $value);
2713 $self->getfield('quantity') || 1;
2716 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2718 Transfers as many services as possible from this package to another package.
2720 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2721 object. The destination package must already exist.
2723 Services are moved only if the destination allows services with the correct
2724 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
2725 this option with caution! No provision is made for export differences
2726 between the old and new service definitions. Probably only should be used
2727 when your exports for all service definitions of a given svcdb are identical.
2728 (attempt a transfer without it first, to move all possible svcpart-matching
2731 Any services that can't be moved remain in the original package.
2733 Returns an error, if there is one; otherwise, returns the number of services
2734 that couldn't be moved.
2739 my ($self, $dest_pkgnum, %opt) = @_;
2745 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2746 $dest = $dest_pkgnum;
2747 $dest_pkgnum = $dest->pkgnum;
2749 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2752 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2754 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2755 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2758 foreach my $cust_svc ($dest->cust_svc) {
2759 $target{$cust_svc->svcpart}--;
2762 my %svcpart2svcparts = ();
2763 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2764 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2765 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2766 next if exists $svcpart2svcparts{$svcpart};
2767 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2768 $svcpart2svcparts{$svcpart} = [
2770 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
2772 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2773 'svcpart' => $_ } );
2775 $pkg_svc ? $pkg_svc->primary_svc : '',
2776 $pkg_svc ? $pkg_svc->quantity : 0,
2780 grep { $_ != $svcpart }
2782 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2784 warn "alternates for svcpart $svcpart: ".
2785 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2790 foreach my $cust_svc ($self->cust_svc) {
2791 if($target{$cust_svc->svcpart} > 0) {
2792 $target{$cust_svc->svcpart}--;
2793 my $new = new FS::cust_svc { $cust_svc->hash };
2794 $new->pkgnum($dest_pkgnum);
2795 my $error = $new->replace($cust_svc);
2796 return $error if $error;
2797 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2799 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2800 warn "alternates to consider: ".
2801 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2803 my @alternate = grep {
2804 warn "considering alternate svcpart $_: ".
2805 "$target{$_} available in new package\n"
2808 } @{$svcpart2svcparts{$cust_svc->svcpart}};
2810 warn "alternate(s) found\n" if $DEBUG;
2811 my $change_svcpart = $alternate[0];
2812 $target{$change_svcpart}--;
2813 my $new = new FS::cust_svc { $cust_svc->hash };
2814 $new->svcpart($change_svcpart);
2815 $new->pkgnum($dest_pkgnum);
2816 my $error = $new->replace($cust_svc);
2817 return $error if $error;
2830 This method is deprecated. See the I<depend_jobnum> option to the insert and
2831 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2838 local $SIG{HUP} = 'IGNORE';
2839 local $SIG{INT} = 'IGNORE';
2840 local $SIG{QUIT} = 'IGNORE';
2841 local $SIG{TERM} = 'IGNORE';
2842 local $SIG{TSTP} = 'IGNORE';
2843 local $SIG{PIPE} = 'IGNORE';
2845 my $oldAutoCommit = $FS::UID::AutoCommit;
2846 local $FS::UID::AutoCommit = 0;
2849 foreach my $cust_svc ( $self->cust_svc ) {
2850 #false laziness w/svc_Common::insert
2851 my $svc_x = $cust_svc->svc_x;
2852 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2853 my $error = $part_export->export_insert($svc_x);
2855 $dbh->rollback if $oldAutoCommit;
2861 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2868 Associates this package with a (suspension or cancellation) reason (see
2869 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2872 Available options are:
2878 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.
2882 the access_user (see L<FS::access_user>) providing the reason
2890 the action (cancel, susp, adjourn, expire) associated with the reason
2894 If there is an error, returns the error, otherwise returns false.
2899 my ($self, %options) = @_;
2901 my $otaker = $options{reason_otaker} ||
2902 $FS::CurrentUser::CurrentUser->username;
2905 if ( $options{'reason'} =~ /^(\d+)$/ ) {
2909 } elsif ( ref($options{'reason'}) ) {
2911 return 'Enter a new reason (or select an existing one)'
2912 unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2914 my $reason = new FS::reason({
2915 'reason_type' => $options{'reason'}->{'typenum'},
2916 'reason' => $options{'reason'}->{'reason'},
2918 my $error = $reason->insert;
2919 return $error if $error;
2921 $reasonnum = $reason->reasonnum;
2924 return "Unparsable reason: ". $options{'reason'};
2927 my $cust_pkg_reason =
2928 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
2929 'reasonnum' => $reasonnum,
2930 'otaker' => $otaker,
2931 'action' => substr(uc($options{'action'}),0,1),
2932 'date' => $options{'date'}
2937 $cust_pkg_reason->insert;
2940 =item insert_discount
2942 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
2943 inserting a new discount on the fly (see L<FS::discount>).
2945 Available options are:
2953 If there is an error, returns the error, otherwise returns false.
2957 sub insert_discount {
2958 #my ($self, %options) = @_;
2961 my $cust_pkg_discount = new FS::cust_pkg_discount {
2962 'pkgnum' => $self->pkgnum,
2963 'discountnum' => $self->discountnum,
2965 'end_date' => '', #XXX
2966 #for the create a new discount case
2967 '_type' => $self->discountnum__type,
2968 'amount' => $self->discountnum_amount,
2969 'percent' => $self->discountnum_percent,
2970 'months' => $self->discountnum_months,
2971 'setup' => $self->discountnum_setup,
2972 #'disabled' => $self->discountnum_disabled,
2975 $cust_pkg_discount->insert;
2978 =item set_usage USAGE_VALUE_HASHREF
2980 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2981 to which they should be set (see L<FS::svc_acct>). Currently seconds,
2982 upbytes, downbytes, and totalbytes are appropriate keys.
2984 All svc_accts which are part of this package have their values reset.
2989 my ($self, $valueref, %opt) = @_;
2991 #only svc_acct can set_usage for now
2992 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
2993 my $svc_x = $cust_svc->svc_x;
2994 $svc_x->set_usage($valueref, %opt)
2995 if $svc_x->can("set_usage");
2999 =item recharge USAGE_VALUE_HASHREF
3001 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3002 to which they should be set (see L<FS::svc_acct>). Currently seconds,
3003 upbytes, downbytes, and totalbytes are appropriate keys.
3005 All svc_accts which are part of this package have their values incremented.
3010 my ($self, $valueref) = @_;
3012 #only svc_acct can set_usage for now
3013 foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3014 my $svc_x = $cust_svc->svc_x;
3015 $svc_x->recharge($valueref)
3016 if $svc_x->can("recharge");
3020 =item cust_pkg_discount
3024 sub cust_pkg_discount {
3026 qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
3029 =item cust_pkg_discount_active
3033 sub cust_pkg_discount_active {
3035 grep { $_->status eq 'active' } $self->cust_pkg_discount;
3040 =head1 CLASS METHODS
3046 Returns an SQL expression identifying recurring packages.
3050 sub recurring_sql { "
3051 '0' != ( select freq from part_pkg
3052 where cust_pkg.pkgpart = part_pkg.pkgpart )
3057 Returns an SQL expression identifying one-time packages.
3062 '0' = ( select freq from part_pkg
3063 where cust_pkg.pkgpart = part_pkg.pkgpart )
3068 Returns an SQL expression identifying ordered packages (recurring packages not
3074 $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
3079 Returns an SQL expression identifying active packages.
3084 $_[0]->recurring_sql. "
3085 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
3086 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3087 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
3090 =item not_yet_billed_sql
3092 Returns an SQL expression identifying packages which have not yet been billed.
3096 sub not_yet_billed_sql { "
3097 ( cust_pkg.setup IS NULL OR cust_pkg.setup = 0 )
3098 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3099 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
3104 Returns an SQL expression identifying inactive packages (one-time packages
3105 that are otherwise unsuspended/uncancelled).
3109 sub inactive_sql { "
3110 ". $_[0]->onetime_sql(). "
3111 AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
3112 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3113 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
3119 Returns an SQL expression identifying suspended packages.
3123 sub suspended_sql { susp_sql(@_); }
3125 #$_[0]->recurring_sql(). ' AND '.
3127 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3128 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
3135 Returns an SQL exprression identifying cancelled packages.
3139 sub cancelled_sql { cancel_sql(@_); }
3141 #$_[0]->recurring_sql(). ' AND '.
3142 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
3147 Returns an SQL expression to give the package status as a string.
3153 WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
3154 WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
3155 WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
3156 WHEN ".onetime_sql()." THEN 'one-time charge'
3161 =item search HASHREF
3165 Returns a qsearch hash expression to search for parameters specified in HASHREF.
3166 Valid parameters are
3174 active, inactive, suspended, cancel (or cancelled)
3178 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
3182 boolean selects custom packages
3188 pkgpart or arrayref or hashref of pkgparts
3192 arrayref of beginning and ending epoch date
3196 arrayref of beginning and ending epoch date
3200 arrayref of beginning and ending epoch date
3204 arrayref of beginning and ending epoch date
3208 arrayref of beginning and ending epoch date
3212 arrayref of beginning and ending epoch date
3216 arrayref of beginning and ending epoch date
3220 pkgnum or APKG_pkgnum
3224 a value suited to passing to FS::UI::Web::cust_header
3228 specifies the user for agent virtualization
3232 boolean; if true, returns only packages with more than 0 FCC phone lines
3234 =item state, country
3236 Limit to packages whose customer is located in the specified state and
3237 country. For FCC 477 reporting. This will use the customer's service
3238 address if there is one, but isn't yet smart enough to use the package
3246 my ($class, $params) = @_;
3253 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
3255 "cust_main.agentnum = $1";
3262 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
3264 "cust_pkg.custnum = $1";
3271 if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
3273 "cust_pkg.pkgbatch = '$1'";
3280 if ( $params->{'magic'} eq 'active'
3281 || $params->{'status'} eq 'active' ) {
3283 push @where, FS::cust_pkg->active_sql();
3285 } elsif ( $params->{'magic'} =~ /^not[ _]yet[ _]billed$/
3286 || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
3288 push @where, FS::cust_pkg->not_yet_billed_sql();
3290 } elsif ( $params->{'magic'} =~ /^(one-time charge|inactive)/
3291 || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
3293 push @where, FS::cust_pkg->inactive_sql();
3295 } elsif ( $params->{'magic'} eq 'suspended'
3296 || $params->{'status'} eq 'suspended' ) {
3298 push @where, FS::cust_pkg->suspended_sql();
3300 } elsif ( $params->{'magic'} =~ /^cancell?ed$/
3301 || $params->{'status'} =~ /^cancell?ed$/ ) {
3303 push @where, FS::cust_pkg->cancelled_sql();
3308 # parse package class
3311 if ( exists($params->{'classnum'}) ) {
3314 if ( ref($params->{'classnum'}) ) {
3316 if ( ref($params->{'classnum'}) eq 'HASH' ) {
3317 @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
3318 } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
3319 @classnum = @{ $params->{'classnum'} };
3321 die 'unhandled classnum ref '. $params->{'classnum'};
3325 } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
3332 my @nums = grep $_, @classnum;
3333 push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
3334 my $null = scalar( grep { $_ eq '' } @classnum );
3335 push @c_where, 'part_pkg.classnum IS NULL' if $null;
3337 if ( scalar(@c_where) == 1 ) {
3338 push @where, @c_where;
3339 } elsif ( @c_where ) {
3340 push @where, ' ( '. join(' OR ', @c_where). ' ) ';
3349 # parse package report options
3352 my @report_option = ();
3353 if ( exists($params->{'report_option'}) ) {
3354 if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
3355 @report_option = @{ $params->{'report_option'} };
3356 } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
3357 @report_option = split(',', $1);
3362 if (@report_option) {
3363 # this will result in the empty set for the dangling comma case as it should
3365 map{ "0 < ( SELECT count(*) FROM part_pkg_option
3366 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
3367 AND optionname = 'report_option_$_'
3368 AND optionvalue = '1' )"
3372 foreach my $any ( grep /^report_option_any/, keys %$params ) {
3374 my @report_option_any = ();
3375 if ( ref($params->{$any}) eq 'ARRAY' ) {
3376 @report_option_any = @{ $params->{$any} };
3377 } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
3378 @report_option_any = split(',', $1);
3381 if (@report_option_any) {
3382 # this will result in the empty set for the dangling comma case as it should
3383 push @where, ' ( '. join(' OR ',
3384 map{ "0 < ( SELECT count(*) FROM part_pkg_option
3385 WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
3386 AND optionname = 'report_option_$_'
3387 AND optionvalue = '1' )"
3388 } @report_option_any
3398 push @where, "part_pkg.custom = 'Y'" if $params->{custom};
3404 push @where, "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
3405 if $params->{fcc_line};
3411 if ( exists($params->{'censustract'}) ) {
3412 $params->{'censustract'} =~ /^([.\d]*)$/;
3413 my $censustract = "cust_main.censustract = '$1'";
3414 $censustract .= ' OR cust_main.censustract is NULL' unless $1;
3415 push @where, "( $censustract )";
3419 # parse censustract2
3421 if ( exists($params->{'censustract2'})
3422 && $params->{'censustract2'} =~ /^(\d*)$/
3426 push @where, "cust_main.censustract LIKE '$1%'";
3429 "( cust_main.censustract = '' OR cust_main.censustract IS NULL )";
3434 # parse country/state
3437 for (qw(state country)) {
3438 if ( exists($params->{$_})
3439 && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
3442 "COALESCE(cust_location.$_, cust_main.ship_$_, cust_main.$_) = '$1'";
3451 if ( ref($params->{'pkgpart'}) ) {
3454 if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
3455 @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
3456 } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
3457 @pkgpart = @{ $params->{'pkgpart'} };
3459 die 'unhandled pkgpart ref '. $params->{'pkgpart'};
3462 @pkgpart = grep /^(\d+)$/, @pkgpart;
3464 push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
3466 } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3467 push @where, "pkgpart = $1";
3476 #false laziness w/report_cust_pkg.html
3479 'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
3480 'active' => { 'susp'=>1, 'cancel'=>1 },
3481 'suspended' => { 'cancel' => 1 },
3486 if( exists($params->{'active'} ) ) {
3487 # This overrides all the other date-related fields
3488 my($beginning, $ending) = @{$params->{'active'}};
3490 "cust_pkg.setup IS NOT NULL",
3491 "cust_pkg.setup <= $ending",
3492 "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
3493 "NOT (".FS::cust_pkg->onetime_sql . ")";
3496 foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
3498 next unless exists($params->{$field});
3500 my($beginning, $ending) = @{$params->{$field}};
3502 next if $beginning == 0 && $ending == 4294967295;
3505 "cust_pkg.$field IS NOT NULL",
3506 "cust_pkg.$field >= $beginning",
3507 "cust_pkg.$field <= $ending";
3509 $orderby ||= "ORDER BY cust_pkg.$field";
3514 $orderby ||= 'ORDER BY bill';
3517 # parse magic, legacy, etc.
3520 if ( $params->{'magic'} &&
3521 $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
3524 $orderby = 'ORDER BY pkgnum';
3526 if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3527 push @where, "pkgpart = $1";
3530 } elsif ( $params->{'query'} eq 'pkgnum' ) {
3532 $orderby = 'ORDER BY pkgnum';
3534 } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
3536 $orderby = 'ORDER BY pkgnum';
3539 SELECT count(*) FROM pkg_svc
3540 WHERE pkg_svc.pkgpart = cust_pkg.pkgpart
3541 AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
3542 WHERE cust_svc.pkgnum = cust_pkg.pkgnum
3543 AND cust_svc.svcpart = pkg_svc.svcpart
3550 # setup queries, links, subs, etc. for the search
3553 # here is the agent virtualization
3554 if ($params->{CurrentUser}) {
3556 qsearchs('access_user', { username => $params->{CurrentUser} });
3559 push @where, $access_user->agentnums_sql('table'=>'cust_main');
3564 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
3567 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
3569 my $addl_from = 'LEFT JOIN cust_main USING ( custnum ) '.
3570 'LEFT JOIN part_pkg USING ( pkgpart ) '.
3571 'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
3572 'LEFT JOIN cust_location USING ( locationnum ) ';
3576 if ( $params->{'select_zip5'} ) {
3577 my $zip = 'COALESCE(cust_location.zip, cust_main.ship_zip, cust_main.zip)';
3579 $select = "DISTINCT substr($zip,1,5) as zip";
3580 $orderby = "ORDER BY substr($zip,1,5)";
3581 $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
3583 $select = join(', ',
3585 ( map "part_pkg.$_", qw( pkg freq ) ),
3586 'pkg_class.classname',
3587 'cust_main.custnum AS cust_main_custnum',
3588 FS::UI::Web::cust_sql_fields(
3589 $params->{'cust_fields'}
3592 $count_query = 'SELECT COUNT(*)';
3595 $count_query .= " FROM cust_pkg $addl_from $extra_sql";
3598 'table' => 'cust_pkg',
3600 'select' => $select,
3601 'extra_sql' => $extra_sql,
3602 'order_by' => $orderby,
3603 'addl_from' => $addl_from,
3604 'count_query' => $count_query,
3611 Returns a list of two package counts. The first is a count of packages
3612 based on the supplied criteria and the second is the count of residential
3613 packages with those same criteria. Criteria are specified as in the search
3619 my ($class, $params) = @_;
3621 my $sql_query = $class->search( $params );
3623 my $count_sql = delete($sql_query->{'count_query'});
3624 $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
3625 or die "couldn't parse count_sql";
3627 my $count_sth = dbh->prepare($count_sql)
3628 or die "Error preparing $count_sql: ". dbh->errstr;
3630 or die "Error executing $count_sql: ". $count_sth->errstr;
3631 my $count_arrayref = $count_sth->fetchrow_arrayref;
3633 return ( @$count_arrayref );
3640 Returns a list: the first item is an SQL fragment identifying matching
3641 packages/customers via location (taking into account shipping and package
3642 address taxation, if enabled), and subsequent items are the parameters to
3643 substitute for the placeholders in that fragment.
3648 my($class, %opt) = @_;
3649 my $ornull = $opt{'ornull'};
3651 my $conf = new FS::Conf;
3653 # '?' placeholders in _location_sql_where
3654 my $x = $ornull ? 3 : 2;
3665 if ( $conf->exists('tax-ship_address') ) {
3668 ( ( ship_last IS NULL OR ship_last = '' )
3669 AND ". _location_sql_where('cust_main', '', $ornull ). "
3671 OR ( ship_last IS NOT NULL AND ship_last != ''
3672 AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
3675 # AND payby != 'COMP'
3677 @main_param = ( @bill_param, @bill_param );
3681 $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
3682 @main_param = @bill_param;
3688 if ( $conf->exists('tax-pkg_address') ) {
3690 my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
3693 ( cust_pkg.locationnum IS NULL AND $main_where )
3694 OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where )
3697 @param = ( @main_param, @bill_param );
3701 $where = $main_where;
3702 @param = @main_param;
3710 #subroutine, helper for location_sql
3711 sub _location_sql_where {
3713 my $prefix = @_ ? shift : '';
3714 my $ornull = @_ ? shift : '';
3716 # $ornull = $ornull ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
3718 $ornull = $ornull ? ' OR ? IS NULL ' : '';
3720 my $or_empty_city = " OR ( ? = '' AND $table.${prefix}city IS NULL )";
3721 my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL )";
3722 my $or_empty_state = " OR ( ? = '' AND $table.${prefix}state IS NULL )";
3724 my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
3726 # ( $table.${prefix}city = ? $or_empty_city $ornull )
3728 ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
3729 AND ( $table.${prefix}city = ? OR ? = '' OR CAST(? AS $text) IS NULL )
3730 AND ( $table.${prefix}county = ? $or_empty_county $ornull )
3731 AND ( $table.${prefix}state = ? $or_empty_state $ornull )
3732 AND $table.${prefix}country = ?
3737 my( $self, $what ) = @_;
3739 my $what_show_zero = $what. '_show_zero';
3740 length($self->$what_show_zero())
3741 ? ($self->$what_show_zero() eq 'Y')
3742 : $self->part_pkg->$what_show_zero();
3749 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
3751 CUSTNUM is a customer (see L<FS::cust_main>)
3753 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3754 L<FS::part_pkg>) to order for this customer. Duplicates are of course
3757 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
3758 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
3759 new billing items. An error is returned if this is not possible (see
3760 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
3763 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3764 newly-created cust_pkg objects.
3766 REFNUM, if specified, will specify the FS::pkg_referral record to be created
3767 and inserted. Multiple FS::pkg_referral records can be created by
3768 setting I<refnum> to an array reference of refnums or a hash reference with
3769 refnums as keys. If no I<refnum> is defined, a default FS::pkg_referral
3770 record will be created corresponding to cust_main.refnum.
3775 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
3777 my $conf = new FS::Conf;
3779 # Transactionize this whole mess
3780 local $SIG{HUP} = 'IGNORE';
3781 local $SIG{INT} = 'IGNORE';
3782 local $SIG{QUIT} = 'IGNORE';
3783 local $SIG{TERM} = 'IGNORE';
3784 local $SIG{TSTP} = 'IGNORE';
3785 local $SIG{PIPE} = 'IGNORE';
3787 my $oldAutoCommit = $FS::UID::AutoCommit;
3788 local $FS::UID::AutoCommit = 0;
3792 # my $cust_main = qsearchs('cust_main', { custnum => $custnum });
3793 # return "Customer not found: $custnum" unless $cust_main;
3795 warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
3798 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3801 my $change = scalar(@old_cust_pkg) != 0;
3804 if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
3806 warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
3807 " to pkgpart ". $pkgparts->[0]. "\n"
3810 my $err_or_cust_pkg =
3811 $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3812 'refnum' => $refnum,
3815 unless (ref($err_or_cust_pkg)) {
3816 $dbh->rollback if $oldAutoCommit;
3817 return $err_or_cust_pkg;
3820 push @$return_cust_pkg, $err_or_cust_pkg;
3821 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3826 # Create the new packages.
3827 foreach my $pkgpart (@$pkgparts) {
3829 warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3831 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3832 pkgpart => $pkgpart,
3836 $error = $cust_pkg->insert( 'change' => $change );
3838 $dbh->rollback if $oldAutoCommit;
3841 push @$return_cust_pkg, $cust_pkg;
3843 # $return_cust_pkg now contains refs to all of the newly
3846 # Transfer services and cancel old packages.
3847 foreach my $old_pkg (@old_cust_pkg) {
3849 warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3852 foreach my $new_pkg (@$return_cust_pkg) {
3853 $error = $old_pkg->transfer($new_pkg);
3854 if ($error and $error == 0) {
3855 # $old_pkg->transfer failed.
3856 $dbh->rollback if $oldAutoCommit;
3861 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3862 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3863 foreach my $new_pkg (@$return_cust_pkg) {
3864 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3865 if ($error and $error == 0) {
3866 # $old_pkg->transfer failed.
3867 $dbh->rollback if $oldAutoCommit;
3874 # Transfers were successful, but we went through all of the
3875 # new packages and still had services left on the old package.
3876 # We can't cancel the package under the circumstances, so abort.
3877 $dbh->rollback if $oldAutoCommit;
3878 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3880 $error = $old_pkg->cancel( quiet=>1 );
3886 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3890 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3892 A bulk change method to change packages for multiple customers.
3894 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3895 L<FS::part_pkg>) to order for each customer. Duplicates are of course
3898 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3899 replace. The services (see L<FS::cust_svc>) are moved to the
3900 new billing items. An error is returned if this is not possible (see
3903 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3904 newly-created cust_pkg objects.
3909 my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3911 # Transactionize this whole mess
3912 local $SIG{HUP} = 'IGNORE';
3913 local $SIG{INT} = 'IGNORE';
3914 local $SIG{QUIT} = 'IGNORE';
3915 local $SIG{TERM} = 'IGNORE';
3916 local $SIG{TSTP} = 'IGNORE';
3917 local $SIG{PIPE} = 'IGNORE';
3919 my $oldAutoCommit = $FS::UID::AutoCommit;
3920 local $FS::UID::AutoCommit = 0;
3924 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3927 while(scalar(@old_cust_pkg)) {
3929 my $custnum = $old_cust_pkg[0]->custnum;
3930 my (@remove) = map { $_->pkgnum }
3931 grep { $_->custnum == $custnum } @old_cust_pkg;
3932 @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3934 my $error = order $custnum, $pkgparts, \@remove, \@return;
3936 push @errors, $error
3938 push @$return_cust_pkg, @return;
3941 if (scalar(@errors)) {
3942 $dbh->rollback if $oldAutoCommit;
3943 return join(' / ', @errors);
3946 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3950 # Used by FS::Upgrade to migrate to a new database.
3951 sub _upgrade_data { # class method
3952 my ($class, %opts) = @_;
3953 $class->_upgrade_otaker(%opts);
3955 # RT#10139, bug resulting in contract_end being set when it shouldn't
3956 'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
3957 # RT#10830, bad calculation of prorate date near end of year
3958 # the date range for bill is December 2009, and we move it forward
3959 # one year if it's before the previous bill date (which it should
3961 'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
3962 AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
3963 WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
3964 # RT6628, add order_date to cust_pkg
3965 'update cust_pkg set order_date = (select history_date from h_cust_pkg
3966 where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
3967 history_action = \'insert\') where order_date is null',
3969 foreach my $sql (@statements) {
3970 my $sth = dbh->prepare($sql);
3971 $sth->execute or die $sth->errstr;
3979 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
3981 In sub order, the @pkgparts array (passed by reference) is clobbered.
3983 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
3984 method to pass dates to the recur_prog expression, it should do so.
3986 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3987 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3988 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3989 configuration values. Probably need a subroutine which decides what to do
3990 based on whether or not we've fetched the user yet, rather than a hash. See
3991 FS::UID and the TODO.
3993 Now that things are transactional should the check in the insert method be
3998 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3999 L<FS::pkg_svc>, schema.html from the base documentation