4 use vars qw(@ISA $disable_agentcheck @SVCDB_CANCEL_SEQ $DEBUG);
6 use FS::UID qw( getotaker dbh );
7 use FS::Misc qw( send_email );
8 use FS::Record qw( qsearch qsearchs );
9 use FS::cust_main_Mixin;
15 use FS::cust_bill_pkg;
19 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
21 # because they load configuration by setting FS::UID::callback (see TODO)
27 # for sending cancel emails in sub cancel
30 @ISA = qw( FS::cust_main_Mixin FS::Record );
34 $disable_agentcheck = 0;
36 # The order in which to unprovision services.
37 @SVCDB_CANCEL_SEQ = qw( svc_external
46 my ( $hashref, $cache ) = @_;
47 #if ( $hashref->{'pkgpart'} ) {
48 if ( $hashref->{'pkg'} ) {
49 # #@{ $self->{'_pkgnum'} } = ();
50 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
51 # $self->{'_pkgpart'} = $subcache;
52 # #push @{ $self->{'_pkgnum'} },
53 # FS::part_pkg->new_or_cached($hashref, $subcache);
54 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
56 if ( exists $hashref->{'svcnum'} ) {
57 #@{ $self->{'_pkgnum'} } = ();
58 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
59 $self->{'_svcnum'} = $subcache;
60 #push @{ $self->{'_pkgnum'} },
61 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
67 FS::cust_pkg - Object methods for cust_pkg objects
73 $record = new FS::cust_pkg \%hash;
74 $record = new FS::cust_pkg { 'column' => 'value' };
76 $error = $record->insert;
78 $error = $new_record->replace($old_record);
80 $error = $record->delete;
82 $error = $record->check;
84 $error = $record->cancel;
86 $error = $record->suspend;
88 $error = $record->unsuspend;
90 $part_pkg = $record->part_pkg;
92 @labels = $record->labels;
94 $seconds = $record->seconds_since($timestamp);
96 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
97 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
101 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
102 inherits from FS::Record. The following fields are currently supported:
106 =item pkgnum - primary key (assigned automatically for new billing items)
108 =item custnum - Customer (see L<FS::cust_main>)
110 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
114 =item bill - date (next bill date)
116 =item last_bill - last bill date
124 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
126 =item manual_flag - If this field is set to 1, disables the automatic
127 unsuspension of this package when using the B<unsuspendauto> config file.
131 Note: setup, bill, susp, expire and cancel are specified as UNIX timestamps;
132 see L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for
133 conversion functions.
141 Create a new billing item. To add the item to the database, see L<"insert">.
145 sub table { 'cust_pkg'; }
146 sub cust_linked { $_[0]->cust_main_custnum; }
147 sub cust_unlinked_msg {
149 "WARNING: can't find cust_main.custnum ". $self->custnum.
150 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
153 =item insert [ OPTION => VALUE ... ]
155 Adds this billing item to the database ("Orders" the item). If there is an
156 error, returns the error, otherwise returns false.
158 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
159 will be used to look up the package definition and agent restrictions will be
162 The following options are available: I<change>
164 I<change>, if set true, supresses any referral credit to a referring customer.
169 my( $self, %options ) = @_;
171 local $SIG{HUP} = 'IGNORE';
172 local $SIG{INT} = 'IGNORE';
173 local $SIG{QUIT} = 'IGNORE';
174 local $SIG{TERM} = 'IGNORE';
175 local $SIG{TSTP} = 'IGNORE';
176 local $SIG{PIPE} = 'IGNORE';
178 my $oldAutoCommit = $FS::UID::AutoCommit;
179 local $FS::UID::AutoCommit = 0;
182 my $error = $self->SUPER::insert;
184 $dbh->rollback if $oldAutoCommit;
188 #if ( $self->reg_code ) {
189 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
190 # $error = $reg_code->delete;
192 # $dbh->rollback if $oldAutoCommit;
197 my $conf = new FS::Conf;
198 my $cust_main = $self->cust_main;
199 my $part_pkg = $self->part_pkg;
200 if ( $conf->exists('referral_credit')
201 && $cust_main->referral_custnum
202 && ! $options{'change'}
203 && $part_pkg->freq !~ /^0\D?$/
206 my $referring_cust_main = $cust_main->referring_cust_main;
207 if ( $referring_cust_main->status ne 'cancelled' ) {
209 if ( $part_pkg->freq !~ /^\d+$/ ) {
210 warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum.
211 ' for package '. $self->pkgnum.
212 ' ( customer '. $self->custnum. ')'.
213 ' - One-time referral credits not (yet) available for '.
214 ' packages with '. $part_pkg->freq_pretty. ' frequency';
217 my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
219 $referring_cust_main->credit( $amount,
220 'Referral credit for '. $cust_main->name
223 $dbh->rollback if $oldAutoCommit;
224 return "Error crediting customer ". $cust_main->referral_custnum.
225 " for referral: $error";
233 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
240 This method now works but you probably shouldn't use it.
242 You don't want to delete billing items, because there would then be no record
243 the customer ever purchased the item. Instead, see the cancel method.
248 # return "Can't delete cust_pkg records!";
251 =item replace OLD_RECORD
253 Replaces the OLD_RECORD with this one in the database. If there is an error,
254 returns the error, otherwise returns false.
256 Currently, custnum, setup, bill, susp, expire, and cancel may be changed.
258 Changing pkgpart may have disasterous effects. See the order subroutine.
260 setup and bill are normally updated by calling the bill method of a customer
261 object (see L<FS::cust_main>).
263 suspend is normally updated by the suspend and unsuspend methods.
265 cancel is normally updated by the cancel method (and also the order subroutine
273 my( $new, $old ) = ( shift, shift );
275 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
276 return "Can't change otaker!" if $old->otaker ne $new->otaker;
279 #return "Can't change setup once it exists!"
280 # if $old->getfield('setup') &&
281 # $old->getfield('setup') != $new->getfield('setup');
283 #some logic for bill, susp, cancel?
285 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
287 local $SIG{HUP} = 'IGNORE';
288 local $SIG{INT} = 'IGNORE';
289 local $SIG{QUIT} = 'IGNORE';
290 local $SIG{TERM} = 'IGNORE';
291 local $SIG{TSTP} = 'IGNORE';
292 local $SIG{PIPE} = 'IGNORE';
294 my $oldAutoCommit = $FS::UID::AutoCommit;
295 local $FS::UID::AutoCommit = 0;
298 #save off and freeze RADIUS attributes for any associated svc_acct records
300 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
302 #also check for specific exports?
303 # to avoid spurious modify export events
304 @svc_acct = map { $_->svc_x }
305 grep { $_->part_svc->svcdb eq 'svc_acct' }
308 $_->snapshot foreach @svc_acct;
312 my $error = $new->SUPER::replace($old);
314 $dbh->rollback if $oldAutoCommit;
318 #for prepaid packages,
319 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
320 foreach my $old_svc_acct ( @svc_acct ) {
321 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
322 my $s_error = $new_svc_acct->replace($old_svc_acct);
324 $dbh->rollback if $oldAutoCommit;
329 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
336 Checks all fields to make sure this is a valid billing item. If there is an
337 error, returns the error, otherwise returns false. Called by the insert and
346 $self->ut_numbern('pkgnum')
347 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
348 || $self->ut_numbern('pkgpart')
349 || $self->ut_numbern('setup')
350 || $self->ut_numbern('bill')
351 || $self->ut_numbern('susp')
352 || $self->ut_numbern('cancel')
354 return $error if $error;
356 if ( $self->reg_code ) {
358 unless ( grep { $self->pkgpart == $_->pkgpart }
359 map { $_->reg_code_pkg }
360 qsearchs( 'reg_code', { 'code' => $self->reg_code,
361 'agentnum' => $self->cust_main->agentnum })
363 return "Unknown registration code";
366 } elsif ( $self->promo_code ) {
369 qsearchs('part_pkg', {
370 'pkgpart' => $self->pkgpart,
371 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
373 return 'Unknown promotional code' unless $promo_part_pkg;
377 unless ( $disable_agentcheck ) {
379 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
380 my $pkgpart_href = $agent->pkgpart_hashref;
381 return "agent ". $agent->agentnum.
382 " can't purchase pkgpart ". $self->pkgpart
383 unless $pkgpart_href->{ $self->pkgpart };
386 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
387 return $error if $error;
391 $self->otaker(getotaker) unless $self->otaker;
392 $self->otaker =~ /^([\w\.\-]{0,16})$/ or return "Illegal otaker";
395 if ( $self->dbdef_table->column('manual_flag') ) {
396 $self->manual_flag('') if $self->manual_flag eq ' ';
397 $self->manual_flag =~ /^([01]?)$/
398 or return "Illegal manual_flag ". $self->manual_flag;
399 $self->manual_flag($1);
405 =item cancel [ OPTION => VALUE ... ]
407 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
408 in this package, then cancels the package itself (sets the cancel field to
411 Available options are: I<quiet>
413 I<quiet> can be set true to supress email cancellation notices.
415 If there is an error, returns the error, otherwise returns false.
420 my( $self, %options ) = @_;
423 local $SIG{HUP} = 'IGNORE';
424 local $SIG{INT} = 'IGNORE';
425 local $SIG{QUIT} = 'IGNORE';
426 local $SIG{TERM} = 'IGNORE';
427 local $SIG{TSTP} = 'IGNORE';
428 local $SIG{PIPE} = 'IGNORE';
430 my $oldAutoCommit = $FS::UID::AutoCommit;
431 local $FS::UID::AutoCommit = 0;
435 foreach my $cust_svc (
436 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
438 push @{ $svc{$cust_svc->part_svc->svcdb} }, $cust_svc;
441 foreach my $svcdb (@SVCDB_CANCEL_SEQ) {
442 foreach my $cust_svc (@{ $svc{$svcdb} }) {
443 my $error = $cust_svc->cancel;
446 $dbh->rollback if $oldAutoCommit;
447 return "Error cancelling cust_svc: $error";
452 # Add a credit for remaining service
453 my $remaining_value = $self->calc_remain();
454 if ( $remaining_value > 0 ) {
455 my $error = $self->cust_main->credit(
457 'Credit for unused time on '. $self->part_pkg->pkg,
460 $dbh->rollback if $oldAutoCommit;
461 return "Error crediting customer \$$remaining_value for unused time on".
462 $self->part_pkg->pkg. ": $error";
466 unless ( $self->getfield('cancel') ) {
467 my %hash = $self->hash;
468 $hash{'cancel'} = time;
469 my $new = new FS::cust_pkg ( \%hash );
470 $error = $new->replace($self);
472 $dbh->rollback if $oldAutoCommit;
477 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
479 my $conf = new FS::Conf;
480 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
481 if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
482 my $conf = new FS::Conf;
483 my $error = send_email(
484 'from' => $conf->config('invoice_from'),
485 'to' => \@invoicing_list,
486 'subject' => $conf->config('cancelsubject'),
487 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
489 #should this do something on errors?
498 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
499 package, then suspends the package itself (sets the susp field to now).
501 If there is an error, returns the error, otherwise returns false.
509 local $SIG{HUP} = 'IGNORE';
510 local $SIG{INT} = 'IGNORE';
511 local $SIG{QUIT} = 'IGNORE';
512 local $SIG{TERM} = 'IGNORE';
513 local $SIG{TSTP} = 'IGNORE';
514 local $SIG{PIPE} = 'IGNORE';
516 my $oldAutoCommit = $FS::UID::AutoCommit;
517 local $FS::UID::AutoCommit = 0;
520 foreach my $cust_svc (
521 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
523 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
525 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
526 $dbh->rollback if $oldAutoCommit;
527 return "Illegal svcdb value in part_svc!";
530 require "FS/$svcdb.pm";
532 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
534 $error = $svc->suspend;
536 $dbh->rollback if $oldAutoCommit;
543 unless ( $self->getfield('susp') ) {
544 my %hash = $self->hash;
545 $hash{'susp'} = time;
546 my $new = new FS::cust_pkg ( \%hash );
547 $error = $new->replace($self);
549 $dbh->rollback if $oldAutoCommit;
554 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
561 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
562 package, then unsuspends the package itself (clears the susp field).
564 If there is an error, returns the error, otherwise returns false.
572 local $SIG{HUP} = 'IGNORE';
573 local $SIG{INT} = 'IGNORE';
574 local $SIG{QUIT} = 'IGNORE';
575 local $SIG{TERM} = 'IGNORE';
576 local $SIG{TSTP} = 'IGNORE';
577 local $SIG{PIPE} = 'IGNORE';
579 my $oldAutoCommit = $FS::UID::AutoCommit;
580 local $FS::UID::AutoCommit = 0;
583 foreach my $cust_svc (
584 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
586 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
588 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
589 $dbh->rollback if $oldAutoCommit;
590 return "Illegal svcdb value in part_svc!";
593 require "FS/$svcdb.pm";
595 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
597 $error = $svc->unsuspend;
599 $dbh->rollback if $oldAutoCommit;
606 unless ( ! $self->getfield('susp') ) {
607 my %hash = $self->hash;
608 my $inactive = time - $hash{'susp'};
610 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
611 if $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
612 my $new = new FS::cust_pkg ( \%hash );
613 $error = $new->replace($self);
615 $dbh->rollback if $oldAutoCommit;
620 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
627 Returns the last bill date, or if there is no last bill date, the setup date.
628 Useful for billing metered services.
634 if ( $self->dbdef_table->column('last_bill') ) {
635 return $self->setfield('last_bill', $_[0]) if @_;
636 return $self->getfield('last_bill') if $self->getfield('last_bill');
638 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
639 'edate' => $self->bill, } );
640 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
645 Returns the definition for this billing item, as an FS::part_pkg object (see
652 #exists( $self->{'_pkgpart'} )
654 ? $self->{'_pkgpart'}
655 : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
660 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
667 $self->part_pkg->calc_setup($self, @_);
672 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
679 $self->part_pkg->calc_recur($self, @_);
684 Calls the I<calc_remain> of the FS::part_pkg object associated with this
691 $self->part_pkg->calc_remain($self, @_);
696 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
703 $self->part_pkg->calc_cancel($self, @_);
706 =item cust_svc [ SVCPART ]
708 Returns the services for this package, as FS::cust_svc objects (see
709 L<FS::cust_svc>). If a svcpart is specified, return only the matching
718 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
719 'svcpart' => shift, } );
722 #if ( $self->{'_svcnum'} ) {
723 # values %{ $self->{'_svcnum'}->cache };
725 $self->_sort_cust_svc(
726 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
732 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
734 Returns historical services for this package created before END TIMESTAMP and
735 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
736 (see L<FS::h_cust_svc>).
743 $self->_sort_cust_svc(
744 [ qsearch( 'h_cust_svc',
745 { 'pkgnum' => $self->pkgnum, },
746 FS::h_cust_svc->sql_h_search(@_),
753 my( $self, $arrayref ) = @_;
756 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
758 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
759 'svcpart' => $_->svcpart } );
761 $pkg_svc ? $pkg_svc->primary_svc : '',
762 $pkg_svc ? $pkg_svc->quantity : 0,
769 =item num_cust_svc [ SVCPART ]
771 Returns the number of provisioned services for this package. If a svcpart is
772 specified, counts only the matching services.
778 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
779 $sql .= ' AND svcpart = ?' if @_;
780 my $sth = dbh->prepare($sql) or die dbh->errstr;
781 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
782 $sth->fetchrow_arrayref->[0];
785 =item available_part_svc
787 Returns a list FS::part_svc objects representing services included in this
788 package but not yet provisioned. Each FS::part_svc object also has an extra
789 field, I<num_avail>, which specifies the number of available services.
793 sub available_part_svc {
795 grep { $_->num_avail > 0 }
797 my $part_svc = $_->part_svc;
798 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
799 $_->quantity - $self->num_cust_svc($_->svcpart);
802 $self->part_pkg->pkg_svc;
807 Returns a short status string for this package, currently:
813 =item one-time charge
828 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
830 return 'cancelled' if $self->get('cancel');
831 return 'suspended' if $self->susp;
832 return 'not yet billed' unless $self->setup;
833 return 'one-time charge' if $freq =~ /^(0|$)/;
839 Class method that returns the list of possible status strings for pacakges
840 (see L<the status method|/status>). For example:
842 @statuses = FS::cust_pkg->statuses();
846 tie my %statuscolor, 'Tie::IxHash',
847 'not yet billed' => '000000',
848 'one-time charge' => '000000',
849 'active' => '00CC00',
850 'suspended' => 'FF9900',
851 'cancelled' => 'FF0000',
855 my $self = shift; #could be class...
856 grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
857 # mayble split btw one-time vs. recur
863 Returns a hex triplet color string for this package's status.
869 $statuscolor{$self->status};
874 Returns a list of lists, calling the label method for all services
875 (see L<FS::cust_svc>) of this billing item.
881 map { [ $_->label ] } $self->cust_svc;
884 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
886 Like the labels method, but returns historical information on services that
887 were active as of END_TIMESTAMP and (optionally) not cancelled before
890 Returns a list of lists, calling the label method for all (historical) services
891 (see L<FS::h_cust_svc>) of this billing item.
897 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
900 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
902 Like h_labels, except returns a simple flat list, and shortens long
903 (currently >5) lists of identical services to one line that lists the service
904 label and the number of individual services rather than individual items.
912 #tie %labels, 'Tie::IxHash';
913 push @{ $labels{$_->[0]} }, $_->[1]
914 foreach $self->h_labels(@_);
916 foreach my $label ( keys %labels ) {
917 my @values = @{ $labels{$label} };
918 my $num = scalar(@values);
920 push @labels, "$label ($num)";
922 push @labels, map { "$label: $_" } @values;
932 Returns the parent customer object (see L<FS::cust_main>).
938 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
941 =item seconds_since TIMESTAMP
943 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
944 package have been online since TIMESTAMP, according to the session monitor.
946 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
947 L<Time::Local> and L<Date::Parse> for conversion functions.
952 my($self, $since) = @_;
955 foreach my $cust_svc (
956 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
958 $seconds += $cust_svc->seconds_since($since);
965 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
967 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
968 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
971 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
972 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
978 sub seconds_since_sqlradacct {
979 my($self, $start, $end) = @_;
983 foreach my $cust_svc (
985 my $part_svc = $_->part_svc;
986 $part_svc->svcdb eq 'svc_acct'
987 && scalar($part_svc->part_export('sqlradius'));
990 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
997 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
999 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1000 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1004 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1005 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1010 sub attribute_since_sqlradacct {
1011 my($self, $start, $end, $attrib) = @_;
1015 foreach my $cust_svc (
1017 my $part_svc = $_->part_svc;
1018 $part_svc->svcdb eq 'svc_acct'
1019 && scalar($part_svc->part_export('sqlradius'));
1022 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1029 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1031 Transfers as many services as possible from this package to another package.
1033 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1034 object. The destination package must already exist.
1036 Services are moved only if the destination allows services with the correct
1037 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
1038 this option with caution! No provision is made for export differences
1039 between the old and new service definitions. Probably only should be used
1040 when your exports for all service definitions of a given svcdb are identical.
1041 (attempt a transfer without it first, to move all possible svcpart-matching
1044 Any services that can't be moved remain in the original package.
1046 Returns an error, if there is one; otherwise, returns the number of services
1047 that couldn't be moved.
1052 my ($self, $dest_pkgnum, %opt) = @_;
1058 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1059 $dest = $dest_pkgnum;
1060 $dest_pkgnum = $dest->pkgnum;
1062 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1065 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1067 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1068 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1071 foreach my $cust_svc ($dest->cust_svc) {
1072 $target{$cust_svc->svcpart}--;
1075 my %svcpart2svcparts = ();
1076 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1077 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1078 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1079 next if exists $svcpart2svcparts{$svcpart};
1080 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1081 $svcpart2svcparts{$svcpart} = [
1083 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
1085 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1086 'svcpart' => $_ } );
1088 $pkg_svc ? $pkg_svc->primary_svc : '',
1089 $pkg_svc ? $pkg_svc->quantity : 0,
1093 grep { $_ != $svcpart }
1095 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1097 warn "alternates for svcpart $svcpart: ".
1098 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1103 foreach my $cust_svc ($self->cust_svc) {
1104 if($target{$cust_svc->svcpart} > 0) {
1105 $target{$cust_svc->svcpart}--;
1106 my $new = new FS::cust_svc {
1107 svcnum => $cust_svc->svcnum,
1108 svcpart => $cust_svc->svcpart,
1109 pkgnum => $dest_pkgnum,
1111 my $error = $new->replace($cust_svc);
1112 return $error if $error;
1113 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1115 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1116 warn "alternates to consider: ".
1117 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1119 my @alternate = grep {
1120 warn "considering alternate svcpart $_: ".
1121 "$target{$_} available in new package\n"
1124 } @{$svcpart2svcparts{$cust_svc->svcpart}};
1126 warn "alternate(s) found\n" if $DEBUG;
1127 my $change_svcpart = $alternate[0];
1128 $target{$change_svcpart}--;
1129 my $new = new FS::cust_svc {
1130 svcnum => $cust_svc->svcnum,
1131 svcpart => $change_svcpart,
1132 pkgnum => $dest_pkgnum,
1134 my $error = $new->replace($cust_svc);
1135 return $error if $error;
1148 This method is deprecated. See the I<depend_jobnum> option to the insert and
1149 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1156 local $SIG{HUP} = 'IGNORE';
1157 local $SIG{INT} = 'IGNORE';
1158 local $SIG{QUIT} = 'IGNORE';
1159 local $SIG{TERM} = 'IGNORE';
1160 local $SIG{TSTP} = 'IGNORE';
1161 local $SIG{PIPE} = 'IGNORE';
1163 my $oldAutoCommit = $FS::UID::AutoCommit;
1164 local $FS::UID::AutoCommit = 0;
1167 foreach my $cust_svc ( $self->cust_svc ) {
1168 #false laziness w/svc_Common::insert
1169 my $svc_x = $cust_svc->svc_x;
1170 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1171 my $error = $part_export->export_insert($svc_x);
1173 $dbh->rollback if $oldAutoCommit;
1179 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1186 =head1 CLASS METHODS
1192 Returns an SQL expression identifying recurring packages.
1196 sub recurring_sql { "
1197 '0' != ( select freq from part_pkg
1198 where cust_pkg.pkgpart = part_pkg.pkgpart )
1203 Returns an SQL expression identifying one-time packages.
1208 '0' = ( select freq from part_pkg
1209 where cust_pkg.pkgpart = part_pkg.pkgpart )
1214 Returns an SQL expression identifying active packages.
1219 ". $_[0]->recurring_sql(). "
1220 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1221 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1226 Returns an SQL expression identifying inactive packages (one-time packages
1227 that are otherwise unsuspended/uncancelled).
1231 sub inactive_sql { "
1232 ". $_[0]->onetime_sql(). "
1233 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1234 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1240 Returns an SQL expression identifying suspended packages.
1244 sub suspended_sql { susp_sql(@_); }
1246 #$_[0]->recurring_sql(). ' AND '.
1248 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1249 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
1256 Returns an SQL exprression identifying cancelled packages.
1260 sub cancelled_sql { cancel_sql(@_); }
1262 #$_[0]->recurring_sql(). ' AND '.
1263 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1270 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1272 CUSTNUM is a customer (see L<FS::cust_main>)
1274 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1275 L<FS::part_pkg>) to order for this customer. Duplicates are of course
1278 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1279 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
1280 new billing items. An error is returned if this is not possible (see
1281 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
1284 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1285 newly-created cust_pkg objects.
1290 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1292 my $conf = new FS::Conf;
1294 # Transactionize this whole mess
1295 local $SIG{HUP} = 'IGNORE';
1296 local $SIG{INT} = 'IGNORE';
1297 local $SIG{QUIT} = 'IGNORE';
1298 local $SIG{TERM} = 'IGNORE';
1299 local $SIG{TSTP} = 'IGNORE';
1300 local $SIG{PIPE} = 'IGNORE';
1302 my $oldAutoCommit = $FS::UID::AutoCommit;
1303 local $FS::UID::AutoCommit = 0;
1307 my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1308 return "Customer not found: $custnum" unless $cust_main;
1310 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1313 my $change = scalar(@old_cust_pkg) != 0;
1316 if ( scalar(@old_cust_pkg) == 1 ) {
1317 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1318 $hash{'setup'} = time;
1321 # Create the new packages.
1322 foreach my $pkgpart (@$pkgparts) {
1323 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1324 pkgpart => $pkgpart,
1327 $error = $cust_pkg->insert( 'change' => $change );
1329 $dbh->rollback if $oldAutoCommit;
1332 push @$return_cust_pkg, $cust_pkg;
1334 # $return_cust_pkg now contains refs to all of the newly
1337 # Transfer services and cancel old packages.
1338 foreach my $old_pkg (@old_cust_pkg) {
1340 foreach my $new_pkg (@$return_cust_pkg) {
1341 $error = $old_pkg->transfer($new_pkg);
1342 if ($error and $error == 0) {
1343 # $old_pkg->transfer failed.
1344 $dbh->rollback if $oldAutoCommit;
1349 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1350 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1351 foreach my $new_pkg (@$return_cust_pkg) {
1352 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1353 if ($error and $error == 0) {
1354 # $old_pkg->transfer failed.
1355 $dbh->rollback if $oldAutoCommit;
1362 # Transfers were successful, but we went through all of the
1363 # new packages and still had services left on the old package.
1364 # We can't cancel the package under the circumstances, so abort.
1365 $dbh->rollback if $oldAutoCommit;
1366 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1368 $error = $old_pkg->cancel;
1374 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1382 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
1384 In sub order, the @pkgparts array (passed by reference) is clobbered.
1386 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
1387 method to pass dates to the recur_prog expression, it should do so.
1389 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1390 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1391 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1392 configuration values. Probably need a subroutine which decides what to do
1393 based on whether or not we've fetched the user yet, rather than a hash. See
1394 FS::UID and the TODO.
1396 Now that things are transactional should the check in the insert method be
1401 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1402 L<FS::pkg_svc>, schema.html from the base documentation