4 use vars qw(@ISA $disable_agentcheck @SVCDB_CANCEL_SEQ $DEBUG);
5 use FS::UID qw( getotaker dbh );
6 use FS::Misc qw( send_email );
7 use FS::Record qw( qsearch qsearchs );
8 use FS::cust_main_Mixin;
14 use FS::cust_bill_pkg;
18 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
20 # because they load configuration by setting FS::UID::callback (see TODO)
26 # for sending cancel emails in sub cancel
29 @ISA = qw( FS::cust_main_Mixin FS::Record );
33 $disable_agentcheck = 0;
35 # The order in which to unprovision services.
36 @SVCDB_CANCEL_SEQ = qw( svc_external
45 my ( $hashref, $cache ) = @_;
46 #if ( $hashref->{'pkgpart'} ) {
47 if ( $hashref->{'pkg'} ) {
48 # #@{ $self->{'_pkgnum'} } = ();
49 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
50 # $self->{'_pkgpart'} = $subcache;
51 # #push @{ $self->{'_pkgnum'} },
52 # FS::part_pkg->new_or_cached($hashref, $subcache);
53 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
55 if ( exists $hashref->{'svcnum'} ) {
56 #@{ $self->{'_pkgnum'} } = ();
57 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
58 $self->{'_svcnum'} = $subcache;
59 #push @{ $self->{'_pkgnum'} },
60 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
66 FS::cust_pkg - Object methods for cust_pkg objects
72 $record = new FS::cust_pkg \%hash;
73 $record = new FS::cust_pkg { 'column' => 'value' };
75 $error = $record->insert;
77 $error = $new_record->replace($old_record);
79 $error = $record->delete;
81 $error = $record->check;
83 $error = $record->cancel;
85 $error = $record->suspend;
87 $error = $record->unsuspend;
89 $part_pkg = $record->part_pkg;
91 @labels = $record->labels;
93 $seconds = $record->seconds_since($timestamp);
95 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
96 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
100 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
101 inherits from FS::Record. The following fields are currently supported:
105 =item pkgnum - primary key (assigned automatically for new billing items)
107 =item custnum - Customer (see L<FS::cust_main>)
109 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
113 =item bill - date (next bill date)
115 =item last_bill - last bill date
123 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
125 =item manual_flag - If this field is set to 1, disables the automatic
126 unsuspension of this package when using the B<unsuspendauto> config file.
130 Note: setup, bill, susp, expire and cancel are specified as UNIX timestamps;
131 see L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for
132 conversion functions.
140 Create a new billing item. To add the item to the database, see L<"insert">.
144 sub table { 'cust_pkg'; }
145 sub cust_linked { $_[0]->cust_main_custnum; }
146 sub cust_unlinked_msg {
148 "WARNING: can't find cust_main.custnum ". $self->custnum.
149 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
152 =item insert [ OPTION => VALUE ... ]
154 Adds this billing item to the database ("Orders" the item). If there is an
155 error, returns the error, otherwise returns false.
157 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
158 will be used to look up the package definition and agent restrictions will be
161 The following options are available: I<change>
163 I<change>, if set true, supresses any referral credit to a referring customer.
168 my( $self, %options ) = @_;
170 local $SIG{HUP} = 'IGNORE';
171 local $SIG{INT} = 'IGNORE';
172 local $SIG{QUIT} = 'IGNORE';
173 local $SIG{TERM} = 'IGNORE';
174 local $SIG{TSTP} = 'IGNORE';
175 local $SIG{PIPE} = 'IGNORE';
177 my $oldAutoCommit = $FS::UID::AutoCommit;
178 local $FS::UID::AutoCommit = 0;
181 my $error = $self->SUPER::insert;
183 $dbh->rollback if $oldAutoCommit;
187 #if ( $self->reg_code ) {
188 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
189 # $error = $reg_code->delete;
191 # $dbh->rollback if $oldAutoCommit;
196 my $conf = new FS::Conf;
197 my $cust_main = $self->cust_main;
198 my $part_pkg = $self->part_pkg;
199 if ( $conf->exists('referral_credit')
200 && $cust_main->referral_custnum
201 && ! $options{'change'}
202 && $part_pkg->freq !~ /^0\D?$/
205 my $referring_cust_main = $cust_main->referring_cust_main;
206 if ( $referring_cust_main->status ne 'cancelled' ) {
208 if ( $part_pkg->freq !~ /^\d+$/ ) {
209 warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum.
210 ' for package '. $self->pkgnum.
211 ' ( customer '. $self->custnum. ')'.
212 ' - One-time referral credits not (yet) available for '.
213 ' packages with '. $part_pkg->freq_pretty. ' frequency';
216 my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
218 $referring_cust_main->credit( $amount,
219 'Referral credit for '. $cust_main->name
222 $dbh->rollback if $oldAutoCommit;
223 return "Error crediting customer ". $cust_main->referral_custnum.
224 " for referral: $error";
232 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
239 This method now works but you probably shouldn't use it.
241 You don't want to delete billing items, because there would then be no record
242 the customer ever purchased the item. Instead, see the cancel method.
247 # return "Can't delete cust_pkg records!";
250 =item replace OLD_RECORD
252 Replaces the OLD_RECORD with this one in the database. If there is an error,
253 returns the error, otherwise returns false.
255 Currently, custnum, setup, bill, susp, expire, and cancel may be changed.
257 Changing pkgpart may have disasterous effects. See the order subroutine.
259 setup and bill are normally updated by calling the bill method of a customer
260 object (see L<FS::cust_main>).
262 suspend is normally updated by the suspend and unsuspend methods.
264 cancel is normally updated by the cancel method (and also the order subroutine
272 my( $new, $old ) = ( shift, shift );
274 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
275 return "Can't change otaker!" if $old->otaker ne $new->otaker;
278 #return "Can't change setup once it exists!"
279 # if $old->getfield('setup') &&
280 # $old->getfield('setup') != $new->getfield('setup');
282 #some logic for bill, susp, cancel?
284 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
286 local $SIG{HUP} = 'IGNORE';
287 local $SIG{INT} = 'IGNORE';
288 local $SIG{QUIT} = 'IGNORE';
289 local $SIG{TERM} = 'IGNORE';
290 local $SIG{TSTP} = 'IGNORE';
291 local $SIG{PIPE} = 'IGNORE';
293 my $oldAutoCommit = $FS::UID::AutoCommit;
294 local $FS::UID::AutoCommit = 0;
297 #save off and freeze RADIUS attributes for any associated svc_acct records
299 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
301 #also check for specific exports?
302 # to avoid spurious modify export events
303 @svc_acct = map { $_->svc_x }
304 grep { $_->part_svc->svcdb eq 'svc_acct' }
307 $_->snapshot foreach @svc_acct;
311 my $error = $new->SUPER::replace($old);
313 $dbh->rollback if $oldAutoCommit;
317 #for prepaid packages,
318 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
319 foreach my $old_svc_acct ( @svc_acct ) {
320 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
321 my $s_error = $new_svc_acct->replace($old_svc_acct);
323 $dbh->rollback if $oldAutoCommit;
328 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
335 Checks all fields to make sure this is a valid billing item. If there is an
336 error, returns the error, otherwise returns false. Called by the insert and
345 $self->ut_numbern('pkgnum')
346 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
347 || $self->ut_numbern('pkgpart')
348 || $self->ut_numbern('setup')
349 || $self->ut_numbern('bill')
350 || $self->ut_numbern('susp')
351 || $self->ut_numbern('cancel')
353 return $error if $error;
355 if ( $self->reg_code ) {
357 unless ( grep { $self->pkgpart == $_->pkgpart }
358 map { $_->reg_code_pkg }
359 qsearchs( 'reg_code', { 'code' => $self->reg_code,
360 'agentnum' => $self->cust_main->agentnum })
362 return "Unknown registration code";
365 } elsif ( $self->promo_code ) {
368 qsearchs('part_pkg', {
369 'pkgpart' => $self->pkgpart,
370 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
372 return 'Unknown promotional code' unless $promo_part_pkg;
376 unless ( $disable_agentcheck ) {
378 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
379 my $pkgpart_href = $agent->pkgpart_hashref;
380 return "agent ". $agent->agentnum.
381 " can't purchase pkgpart ". $self->pkgpart
382 unless $pkgpart_href->{ $self->pkgpart };
385 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
386 return $error if $error;
390 $self->otaker(getotaker) unless $self->otaker;
391 $self->otaker =~ /^([\w\.\-]{0,16})$/ or return "Illegal otaker";
394 if ( $self->dbdef_table->column('manual_flag') ) {
395 $self->manual_flag('') if $self->manual_flag eq ' ';
396 $self->manual_flag =~ /^([01]?)$/
397 or return "Illegal manual_flag ". $self->manual_flag;
398 $self->manual_flag($1);
404 =item cancel [ OPTION => VALUE ... ]
406 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
407 in this package, then cancels the package itself (sets the cancel field to
410 Available options are: I<quiet>
412 I<quiet> can be set true to supress email cancellation notices.
414 If there is an error, returns the error, otherwise returns false.
419 my( $self, %options ) = @_;
422 local $SIG{HUP} = 'IGNORE';
423 local $SIG{INT} = 'IGNORE';
424 local $SIG{QUIT} = 'IGNORE';
425 local $SIG{TERM} = 'IGNORE';
426 local $SIG{TSTP} = 'IGNORE';
427 local $SIG{PIPE} = 'IGNORE';
429 my $oldAutoCommit = $FS::UID::AutoCommit;
430 local $FS::UID::AutoCommit = 0;
434 foreach my $cust_svc (
435 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
437 push @{ $svc{$cust_svc->part_svc->svcdb} }, $cust_svc;
440 foreach my $svcdb (@SVCDB_CANCEL_SEQ) {
441 foreach my $cust_svc (@{ $svc{$svcdb} }) {
442 my $error = $cust_svc->cancel;
445 $dbh->rollback if $oldAutoCommit;
446 return "Error cancelling cust_svc: $error";
451 # Add a credit for remaining service
452 my $remaining_value = $self->calc_remain();
453 if ( $remaining_value > 0 ) {
454 my $error = $self->cust_main->credit(
456 'Credit for unused time on '. $self->part_pkg->pkg,
459 $dbh->rollback if $oldAutoCommit;
460 return "Error crediting customer \$$remaining_value for unused time on".
461 $self->part_pkg->pkg. ": $error";
465 unless ( $self->getfield('cancel') ) {
466 my %hash = $self->hash;
467 $hash{'cancel'} = time;
468 my $new = new FS::cust_pkg ( \%hash );
469 $error = $new->replace($self);
471 $dbh->rollback if $oldAutoCommit;
476 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
478 my $conf = new FS::Conf;
479 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
480 if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
481 my $conf = new FS::Conf;
482 my $error = send_email(
483 'from' => $conf->config('invoice_from'),
484 'to' => \@invoicing_list,
485 'subject' => $conf->config('cancelsubject'),
486 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
488 #should this do something on errors?
497 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
498 package, then suspends the package itself (sets the susp field to now).
500 If there is an error, returns the error, otherwise returns false.
508 local $SIG{HUP} = 'IGNORE';
509 local $SIG{INT} = 'IGNORE';
510 local $SIG{QUIT} = 'IGNORE';
511 local $SIG{TERM} = 'IGNORE';
512 local $SIG{TSTP} = 'IGNORE';
513 local $SIG{PIPE} = 'IGNORE';
515 my $oldAutoCommit = $FS::UID::AutoCommit;
516 local $FS::UID::AutoCommit = 0;
519 foreach my $cust_svc (
520 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
522 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
524 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
525 $dbh->rollback if $oldAutoCommit;
526 return "Illegal svcdb value in part_svc!";
529 require "FS/$svcdb.pm";
531 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
533 $error = $svc->suspend;
535 $dbh->rollback if $oldAutoCommit;
542 unless ( $self->getfield('susp') ) {
543 my %hash = $self->hash;
544 $hash{'susp'} = time;
545 my $new = new FS::cust_pkg ( \%hash );
546 $error = $new->replace($self);
548 $dbh->rollback if $oldAutoCommit;
553 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
560 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
561 package, then unsuspends the package itself (clears the susp field).
563 If there is an error, returns the error, otherwise returns false.
571 local $SIG{HUP} = 'IGNORE';
572 local $SIG{INT} = 'IGNORE';
573 local $SIG{QUIT} = 'IGNORE';
574 local $SIG{TERM} = 'IGNORE';
575 local $SIG{TSTP} = 'IGNORE';
576 local $SIG{PIPE} = 'IGNORE';
578 my $oldAutoCommit = $FS::UID::AutoCommit;
579 local $FS::UID::AutoCommit = 0;
582 foreach my $cust_svc (
583 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
585 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
587 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
588 $dbh->rollback if $oldAutoCommit;
589 return "Illegal svcdb value in part_svc!";
592 require "FS/$svcdb.pm";
594 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
596 $error = $svc->unsuspend;
598 $dbh->rollback if $oldAutoCommit;
605 unless ( ! $self->getfield('susp') ) {
606 my %hash = $self->hash;
607 my $inactive = time - $hash{'susp'};
609 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
610 if $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
611 my $new = new FS::cust_pkg ( \%hash );
612 $error = $new->replace($self);
614 $dbh->rollback if $oldAutoCommit;
619 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
626 Returns the last bill date, or if there is no last bill date, the setup date.
627 Useful for billing metered services.
633 if ( $self->dbdef_table->column('last_bill') ) {
634 return $self->setfield('last_bill', $_[0]) if @_;
635 return $self->getfield('last_bill') if $self->getfield('last_bill');
637 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
638 'edate' => $self->bill, } );
639 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
644 Returns the definition for this billing item, as an FS::part_pkg object (see
651 #exists( $self->{'_pkgpart'} )
653 ? $self->{'_pkgpart'}
654 : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
659 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
666 $self->part_pkg->calc_setup($self, @_);
671 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
678 $self->part_pkg->calc_recur($self, @_);
683 Calls the I<calc_remain> of the FS::part_pkg object associated with this
690 $self->part_pkg->calc_remain($self, @_);
695 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
702 $self->part_pkg->calc_cancel($self, @_);
705 =item cust_svc [ SVCPART ]
707 Returns the services for this package, as FS::cust_svc objects (see
708 L<FS::cust_svc>). If a svcpart is specified, return only the matching
717 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
718 'svcpart' => shift, } );
721 #if ( $self->{'_svcnum'} ) {
722 # values %{ $self->{'_svcnum'}->cache };
724 $self->_sort_cust_svc(
725 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
731 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
733 Returns historical services for this package created before END TIMESTAMP and
734 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
735 (see L<FS::h_cust_svc>).
742 $self->_sort_cust_svc(
743 [ qsearch( 'h_cust_svc',
744 { 'pkgnum' => $self->pkgnum, },
745 FS::h_cust_svc->sql_h_search(@_),
752 my( $self, $arrayref ) = @_;
755 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
757 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
758 'svcpart' => $_->svcpart } );
760 $pkg_svc ? $pkg_svc->primary_svc : '',
761 $pkg_svc ? $pkg_svc->quantity : 0,
768 =item num_cust_svc [ SVCPART ]
770 Returns the number of provisioned services for this package. If a svcpart is
771 specified, counts only the matching services.
777 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
778 $sql .= ' AND svcpart = ?' if @_;
779 my $sth = dbh->prepare($sql) or die dbh->errstr;
780 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
781 $sth->fetchrow_arrayref->[0];
784 =item available_part_svc
786 Returns a list FS::part_svc objects representing services included in this
787 package but not yet provisioned. Each FS::part_svc object also has an extra
788 field, I<num_avail>, which specifies the number of available services.
792 sub available_part_svc {
794 grep { $_->num_avail > 0 }
796 my $part_svc = $_->part_svc;
797 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
798 $_->quantity - $self->num_cust_svc($_->svcpart);
801 $self->part_pkg->pkg_svc;
806 Returns a short status string for this package, currently:
812 =item one-time charge
827 return 'cancelled' if $self->get('cancel');
828 return 'suspended' if $self->susp;
829 return 'not yet billed' unless $self->setup;
830 return 'one-time charge' if $self->part_pkg->freq =~ /^(0|$)/;
836 Returns a hex triplet color string for this package's status.
841 'not yet billed' => '000000',
842 'one-time charge' => '000000',
843 'active' => '00CC00',
844 'suspended' => 'FF9900',
845 'cancelled' => 'FF0000',
849 $statuscolor{$self->status};
854 Returns a list of lists, calling the label method for all services
855 (see L<FS::cust_svc>) of this billing item.
861 map { [ $_->label ] } $self->cust_svc;
864 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
866 Like the labels method, but returns historical information on services that
867 were active as of END_TIMESTAMP and (optionally) not cancelled before
870 Returns a list of lists, calling the label method for all (historical) services
871 (see L<FS::h_cust_svc>) of this billing item.
877 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
880 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
882 Like h_labels, except returns a simple flat list, and shortens long
883 (currently >5) lists of identical services to one line that lists the service
884 label and the number of individual services rather than individual items.
892 #tie %labels, 'Tie::IxHash';
893 push @{ $labels{$_->[0]} }, $_->[1]
894 foreach $self->h_labels(@_);
896 foreach my $label ( keys %labels ) {
897 my @values = @{ $labels{$label} };
898 my $num = scalar(@values);
900 push @labels, "$label ($num)";
902 push @labels, map { "$label: $_" } @values;
912 Returns the parent customer object (see L<FS::cust_main>).
918 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
921 =item seconds_since TIMESTAMP
923 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
924 package have been online since TIMESTAMP, according to the session monitor.
926 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
927 L<Time::Local> and L<Date::Parse> for conversion functions.
932 my($self, $since) = @_;
935 foreach my $cust_svc (
936 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
938 $seconds += $cust_svc->seconds_since($since);
945 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
947 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
948 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
951 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
952 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
958 sub seconds_since_sqlradacct {
959 my($self, $start, $end) = @_;
963 foreach my $cust_svc (
965 my $part_svc = $_->part_svc;
966 $part_svc->svcdb eq 'svc_acct'
967 && scalar($part_svc->part_export('sqlradius'));
970 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
977 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
979 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
980 in this package for sessions ending between TIMESTAMP_START (inclusive) and
984 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
985 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
990 sub attribute_since_sqlradacct {
991 my($self, $start, $end, $attrib) = @_;
995 foreach my $cust_svc (
997 my $part_svc = $_->part_svc;
998 $part_svc->svcdb eq 'svc_acct'
999 && scalar($part_svc->part_export('sqlradius'));
1002 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1009 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1011 Transfers as many services as possible from this package to another package.
1013 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1014 object. The destination package must already exist.
1016 Services are moved only if the destination allows services with the correct
1017 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
1018 this option with caution! No provision is made for export differences
1019 between the old and new service definitions. Probably only should be used
1020 when your exports for all service definitions of a given svcdb are identical.
1021 (attempt a transfer without it first, to move all possible svcpart-matching
1024 Any services that can't be moved remain in the original package.
1026 Returns an error, if there is one; otherwise, returns the number of services
1027 that couldn't be moved.
1032 my ($self, $dest_pkgnum, %opt) = @_;
1038 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1039 $dest = $dest_pkgnum;
1040 $dest_pkgnum = $dest->pkgnum;
1042 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1045 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1047 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1048 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1051 foreach my $cust_svc ($dest->cust_svc) {
1052 $target{$cust_svc->svcpart}--;
1055 my %svcpart2svcparts = ();
1056 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1057 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1058 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1059 next if exists $svcpart2svcparts{$svcpart};
1060 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1061 $svcpart2svcparts{$svcpart} = [
1063 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
1065 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1066 'svcpart' => $_ } );
1068 $pkg_svc ? $pkg_svc->primary_svc : '',
1069 $pkg_svc ? $pkg_svc->quantity : 0,
1073 grep { $_ != $svcpart }
1075 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1077 warn "alternates for svcpart $svcpart: ".
1078 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1083 foreach my $cust_svc ($self->cust_svc) {
1084 if($target{$cust_svc->svcpart} > 0) {
1085 $target{$cust_svc->svcpart}--;
1086 my $new = new FS::cust_svc {
1087 svcnum => $cust_svc->svcnum,
1088 svcpart => $cust_svc->svcpart,
1089 pkgnum => $dest_pkgnum,
1091 my $error = $new->replace($cust_svc);
1092 return $error if $error;
1093 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1095 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1096 warn "alternates to consider: ".
1097 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1099 my @alternate = grep {
1100 warn "considering alternate svcpart $_: ".
1101 "$target{$_} available in new package\n"
1104 } @{$svcpart2svcparts{$cust_svc->svcpart}};
1106 warn "alternate(s) found\n" if $DEBUG;
1107 my $change_svcpart = $alternate[0];
1108 $target{$change_svcpart}--;
1109 my $new = new FS::cust_svc {
1110 svcnum => $cust_svc->svcnum,
1111 svcpart => $change_svcpart,
1112 pkgnum => $dest_pkgnum,
1114 my $error = $new->replace($cust_svc);
1115 return $error if $error;
1128 This method is deprecated. See the I<depend_jobnum> option to the insert and
1129 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1136 local $SIG{HUP} = 'IGNORE';
1137 local $SIG{INT} = 'IGNORE';
1138 local $SIG{QUIT} = 'IGNORE';
1139 local $SIG{TERM} = 'IGNORE';
1140 local $SIG{TSTP} = 'IGNORE';
1141 local $SIG{PIPE} = 'IGNORE';
1143 my $oldAutoCommit = $FS::UID::AutoCommit;
1144 local $FS::UID::AutoCommit = 0;
1147 foreach my $cust_svc ( $self->cust_svc ) {
1148 #false laziness w/svc_Common::insert
1149 my $svc_x = $cust_svc->svc_x;
1150 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1151 my $error = $part_export->export_insert($svc_x);
1153 $dbh->rollback if $oldAutoCommit;
1159 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1172 Returns an SQL expression identifying recurring packages.
1176 sub recurring_sql { "
1177 '0' != ( select freq from part_pkg
1178 where cust_pkg.pkgpart = part_pkg.pkgpart )
1183 Returns an SQL expression identifying active packages.
1188 ". $_[0]->recurring_sql(). "
1189 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1190 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1196 Returns an SQL expression identifying suspended packages.
1200 sub suspended_sql { susp_sql(@_); }
1202 ". $_[0]->recurring_sql(). "
1203 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1204 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
1210 Returns an SQL exprression identifying cancelled packages.
1214 sub cancelled_sql { cancel_sql(@_); }
1216 ". $_[0]->recurring_sql(). "
1217 AND cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0
1224 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1226 CUSTNUM is a customer (see L<FS::cust_main>)
1228 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1229 L<FS::part_pkg>) to order for this customer. Duplicates are of course
1232 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1233 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
1234 new billing items. An error is returned if this is not possible (see
1235 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
1238 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1239 newly-created cust_pkg objects.
1244 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1246 my $conf = new FS::Conf;
1248 # Transactionize this whole mess
1249 local $SIG{HUP} = 'IGNORE';
1250 local $SIG{INT} = 'IGNORE';
1251 local $SIG{QUIT} = 'IGNORE';
1252 local $SIG{TERM} = 'IGNORE';
1253 local $SIG{TSTP} = 'IGNORE';
1254 local $SIG{PIPE} = 'IGNORE';
1256 my $oldAutoCommit = $FS::UID::AutoCommit;
1257 local $FS::UID::AutoCommit = 0;
1261 my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1262 return "Customer not found: $custnum" unless $cust_main;
1264 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1267 my $change = scalar(@old_cust_pkg) != 0;
1270 if ( scalar(@old_cust_pkg) == 1 ) {
1271 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1272 $hash{'setup'} = time;
1275 # Create the new packages.
1276 foreach my $pkgpart (@$pkgparts) {
1277 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1278 pkgpart => $pkgpart,
1281 $error = $cust_pkg->insert( 'change' => $change );
1283 $dbh->rollback if $oldAutoCommit;
1286 push @$return_cust_pkg, $cust_pkg;
1288 # $return_cust_pkg now contains refs to all of the newly
1291 # Transfer services and cancel old packages.
1292 foreach my $old_pkg (@old_cust_pkg) {
1294 foreach my $new_pkg (@$return_cust_pkg) {
1295 $error = $old_pkg->transfer($new_pkg);
1296 if ($error and $error == 0) {
1297 # $old_pkg->transfer failed.
1298 $dbh->rollback if $oldAutoCommit;
1303 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1304 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1305 foreach my $new_pkg (@$return_cust_pkg) {
1306 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1307 if ($error and $error == 0) {
1308 # $old_pkg->transfer failed.
1309 $dbh->rollback if $oldAutoCommit;
1316 # Transfers were successful, but we went through all of the
1317 # new packages and still had services left on the old package.
1318 # We can't cancel the package under the circumstances, so abort.
1319 $dbh->rollback if $oldAutoCommit;
1320 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1322 $error = $old_pkg->cancel;
1328 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1336 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
1338 In sub order, the @pkgparts array (passed by reference) is clobbered.
1340 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
1341 method to pass dates to the recur_prog expression, it should do so.
1343 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1344 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1345 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1346 configuration values. Probably need a subroutine which decides what to do
1347 based on whether or not we've fetched the user yet, rather than a hash. See
1348 FS::UID and the TODO.
1350 Now that things are transactional should the check in the insert method be
1355 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1356 L<FS::pkg_svc>, schema.html from the base documentation