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;
559 =item unsuspend [ OPTION => VALUE ... ]
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 Available options are: I<adjust_next_bill>.
566 I<adjust_next_bill> can be set true to adjust the next bill date forward by
567 the amount of time the account was inactive. This was set true by default
568 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
569 explicitly requested. Price plans for which this makes sense (anniversary-date
570 based than prorate or subscription) could have an option to enable this
573 If there is an error, returns the error, otherwise returns false.
578 my( $self, %opt ) = @_;
581 local $SIG{HUP} = 'IGNORE';
582 local $SIG{INT} = 'IGNORE';
583 local $SIG{QUIT} = 'IGNORE';
584 local $SIG{TERM} = 'IGNORE';
585 local $SIG{TSTP} = 'IGNORE';
586 local $SIG{PIPE} = 'IGNORE';
588 my $oldAutoCommit = $FS::UID::AutoCommit;
589 local $FS::UID::AutoCommit = 0;
592 foreach my $cust_svc (
593 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
595 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
597 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
598 $dbh->rollback if $oldAutoCommit;
599 return "Illegal svcdb value in part_svc!";
602 require "FS/$svcdb.pm";
604 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
606 $error = $svc->unsuspend;
608 $dbh->rollback if $oldAutoCommit;
615 unless ( ! $self->getfield('susp') ) {
616 my %hash = $self->hash;
617 my $inactive = time - $hash{'susp'};
619 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
620 if $opt{'adjust_next_bill'}
621 && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
624 my $new = new FS::cust_pkg ( \%hash );
625 $error = $new->replace($self);
627 $dbh->rollback if $oldAutoCommit;
632 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
639 Returns the last bill date, or if there is no last bill date, the setup date.
640 Useful for billing metered services.
646 if ( $self->dbdef_table->column('last_bill') ) {
647 return $self->setfield('last_bill', $_[0]) if @_;
648 return $self->getfield('last_bill') if $self->getfield('last_bill');
650 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
651 'edate' => $self->bill, } );
652 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
657 Returns the definition for this billing item, as an FS::part_pkg object (see
664 #exists( $self->{'_pkgpart'} )
666 ? $self->{'_pkgpart'}
667 : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
672 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
679 $self->part_pkg->calc_setup($self, @_);
684 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
691 $self->part_pkg->calc_recur($self, @_);
696 Calls the I<calc_remain> of the FS::part_pkg object associated with this
703 $self->part_pkg->calc_remain($self, @_);
708 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
715 $self->part_pkg->calc_cancel($self, @_);
718 =item cust_svc [ SVCPART ]
720 Returns the services for this package, as FS::cust_svc objects (see
721 L<FS::cust_svc>). If a svcpart is specified, return only the matching
730 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
731 'svcpart' => shift, } );
734 #if ( $self->{'_svcnum'} ) {
735 # values %{ $self->{'_svcnum'}->cache };
737 $self->_sort_cust_svc(
738 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
744 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
746 Returns historical services for this package created before END TIMESTAMP and
747 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
748 (see L<FS::h_cust_svc>).
755 $self->_sort_cust_svc(
756 [ qsearch( 'h_cust_svc',
757 { 'pkgnum' => $self->pkgnum, },
758 FS::h_cust_svc->sql_h_search(@_),
765 my( $self, $arrayref ) = @_;
768 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
770 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
771 'svcpart' => $_->svcpart } );
773 $pkg_svc ? $pkg_svc->primary_svc : '',
774 $pkg_svc ? $pkg_svc->quantity : 0,
781 =item num_cust_svc [ SVCPART ]
783 Returns the number of provisioned services for this package. If a svcpart is
784 specified, counts only the matching services.
790 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
791 $sql .= ' AND svcpart = ?' if @_;
792 my $sth = dbh->prepare($sql) or die dbh->errstr;
793 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
794 $sth->fetchrow_arrayref->[0];
797 =item available_part_svc
799 Returns a list FS::part_svc objects representing services included in this
800 package but not yet provisioned. Each FS::part_svc object also has an extra
801 field, I<num_avail>, which specifies the number of available services.
805 sub available_part_svc {
807 grep { $_->num_avail > 0 }
809 my $part_svc = $_->part_svc;
810 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
811 $_->quantity - $self->num_cust_svc($_->svcpart);
814 $self->part_pkg->pkg_svc;
819 Returns a short status string for this package, currently:
825 =item one-time charge
840 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
842 return 'cancelled' if $self->get('cancel');
843 return 'suspended' if $self->susp;
844 return 'not yet billed' unless $self->setup;
845 return 'one-time charge' if $freq =~ /^(0|$)/;
851 Class method that returns the list of possible status strings for pacakges
852 (see L<the status method|/status>). For example:
854 @statuses = FS::cust_pkg->statuses();
858 tie my %statuscolor, 'Tie::IxHash',
859 'not yet billed' => '000000',
860 'one-time charge' => '000000',
861 'active' => '00CC00',
862 'suspended' => 'FF9900',
863 'cancelled' => 'FF0000',
867 my $self = shift; #could be class...
868 grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
869 # mayble split btw one-time vs. recur
875 Returns a hex triplet color string for this package's status.
881 $statuscolor{$self->status};
886 Returns a list of lists, calling the label method for all services
887 (see L<FS::cust_svc>) of this billing item.
893 map { [ $_->label ] } $self->cust_svc;
896 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
898 Like the labels method, but returns historical information on services that
899 were active as of END_TIMESTAMP and (optionally) not cancelled before
902 Returns a list of lists, calling the label method for all (historical) services
903 (see L<FS::h_cust_svc>) of this billing item.
909 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
912 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
914 Like h_labels, except returns a simple flat list, and shortens long
915 (currently >5) lists of identical services to one line that lists the service
916 label and the number of individual services rather than individual items.
924 #tie %labels, 'Tie::IxHash';
925 push @{ $labels{$_->[0]} }, $_->[1]
926 foreach $self->h_labels(@_);
928 foreach my $label ( keys %labels ) {
929 my @values = @{ $labels{$label} };
930 my $num = scalar(@values);
932 push @labels, "$label ($num)";
934 push @labels, map { "$label: $_" } @values;
944 Returns the parent customer object (see L<FS::cust_main>).
950 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
953 =item seconds_since TIMESTAMP
955 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
956 package have been online since TIMESTAMP, according to the session monitor.
958 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
959 L<Time::Local> and L<Date::Parse> for conversion functions.
964 my($self, $since) = @_;
967 foreach my $cust_svc (
968 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
970 $seconds += $cust_svc->seconds_since($since);
977 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
979 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
980 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
983 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
984 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
990 sub seconds_since_sqlradacct {
991 my($self, $start, $end) = @_;
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 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1009 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1011 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1012 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1016 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1017 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1022 sub attribute_since_sqlradacct {
1023 my($self, $start, $end, $attrib) = @_;
1027 foreach my $cust_svc (
1029 my $part_svc = $_->part_svc;
1030 $part_svc->svcdb eq 'svc_acct'
1031 && scalar($part_svc->part_export('sqlradius'));
1034 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1041 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1043 Transfers as many services as possible from this package to another package.
1045 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1046 object. The destination package must already exist.
1048 Services are moved only if the destination allows services with the correct
1049 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
1050 this option with caution! No provision is made for export differences
1051 between the old and new service definitions. Probably only should be used
1052 when your exports for all service definitions of a given svcdb are identical.
1053 (attempt a transfer without it first, to move all possible svcpart-matching
1056 Any services that can't be moved remain in the original package.
1058 Returns an error, if there is one; otherwise, returns the number of services
1059 that couldn't be moved.
1064 my ($self, $dest_pkgnum, %opt) = @_;
1070 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1071 $dest = $dest_pkgnum;
1072 $dest_pkgnum = $dest->pkgnum;
1074 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1077 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1079 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1080 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1083 foreach my $cust_svc ($dest->cust_svc) {
1084 $target{$cust_svc->svcpart}--;
1087 my %svcpart2svcparts = ();
1088 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1089 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1090 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1091 next if exists $svcpart2svcparts{$svcpart};
1092 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1093 $svcpart2svcparts{$svcpart} = [
1095 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
1097 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1098 'svcpart' => $_ } );
1100 $pkg_svc ? $pkg_svc->primary_svc : '',
1101 $pkg_svc ? $pkg_svc->quantity : 0,
1105 grep { $_ != $svcpart }
1107 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1109 warn "alternates for svcpart $svcpart: ".
1110 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1115 foreach my $cust_svc ($self->cust_svc) {
1116 if($target{$cust_svc->svcpart} > 0) {
1117 $target{$cust_svc->svcpart}--;
1118 my $new = new FS::cust_svc {
1119 svcnum => $cust_svc->svcnum,
1120 svcpart => $cust_svc->svcpart,
1121 pkgnum => $dest_pkgnum,
1123 my $error = $new->replace($cust_svc);
1124 return $error if $error;
1125 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1127 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1128 warn "alternates to consider: ".
1129 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1131 my @alternate = grep {
1132 warn "considering alternate svcpart $_: ".
1133 "$target{$_} available in new package\n"
1136 } @{$svcpart2svcparts{$cust_svc->svcpart}};
1138 warn "alternate(s) found\n" if $DEBUG;
1139 my $change_svcpart = $alternate[0];
1140 $target{$change_svcpart}--;
1141 my $new = new FS::cust_svc {
1142 svcnum => $cust_svc->svcnum,
1143 svcpart => $change_svcpart,
1144 pkgnum => $dest_pkgnum,
1146 my $error = $new->replace($cust_svc);
1147 return $error if $error;
1160 This method is deprecated. See the I<depend_jobnum> option to the insert and
1161 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1168 local $SIG{HUP} = 'IGNORE';
1169 local $SIG{INT} = 'IGNORE';
1170 local $SIG{QUIT} = 'IGNORE';
1171 local $SIG{TERM} = 'IGNORE';
1172 local $SIG{TSTP} = 'IGNORE';
1173 local $SIG{PIPE} = 'IGNORE';
1175 my $oldAutoCommit = $FS::UID::AutoCommit;
1176 local $FS::UID::AutoCommit = 0;
1179 foreach my $cust_svc ( $self->cust_svc ) {
1180 #false laziness w/svc_Common::insert
1181 my $svc_x = $cust_svc->svc_x;
1182 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1183 my $error = $part_export->export_insert($svc_x);
1185 $dbh->rollback if $oldAutoCommit;
1191 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1198 =head1 CLASS METHODS
1204 Returns an SQL expression identifying recurring packages.
1208 sub recurring_sql { "
1209 '0' != ( select freq from part_pkg
1210 where cust_pkg.pkgpart = part_pkg.pkgpart )
1215 Returns an SQL expression identifying one-time packages.
1220 '0' = ( select freq from part_pkg
1221 where cust_pkg.pkgpart = part_pkg.pkgpart )
1226 Returns an SQL expression identifying active packages.
1231 ". $_[0]->recurring_sql(). "
1232 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1233 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1238 Returns an SQL expression identifying inactive packages (one-time packages
1239 that are otherwise unsuspended/uncancelled).
1243 sub inactive_sql { "
1244 ". $_[0]->onetime_sql(). "
1245 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1246 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1252 Returns an SQL expression identifying suspended packages.
1256 sub suspended_sql { susp_sql(@_); }
1258 #$_[0]->recurring_sql(). ' AND '.
1260 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1261 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
1268 Returns an SQL exprression identifying cancelled packages.
1272 sub cancelled_sql { cancel_sql(@_); }
1274 #$_[0]->recurring_sql(). ' AND '.
1275 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1282 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1284 CUSTNUM is a customer (see L<FS::cust_main>)
1286 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1287 L<FS::part_pkg>) to order for this customer. Duplicates are of course
1290 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1291 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
1292 new billing items. An error is returned if this is not possible (see
1293 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
1296 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1297 newly-created cust_pkg objects.
1302 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1304 my $conf = new FS::Conf;
1306 # Transactionize this whole mess
1307 local $SIG{HUP} = 'IGNORE';
1308 local $SIG{INT} = 'IGNORE';
1309 local $SIG{QUIT} = 'IGNORE';
1310 local $SIG{TERM} = 'IGNORE';
1311 local $SIG{TSTP} = 'IGNORE';
1312 local $SIG{PIPE} = 'IGNORE';
1314 my $oldAutoCommit = $FS::UID::AutoCommit;
1315 local $FS::UID::AutoCommit = 0;
1319 my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1320 return "Customer not found: $custnum" unless $cust_main;
1322 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1325 my $change = scalar(@old_cust_pkg) != 0;
1328 if ( scalar(@old_cust_pkg) == 1 ) {
1329 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1330 $hash{'setup'} = time;
1333 # Create the new packages.
1334 foreach my $pkgpart (@$pkgparts) {
1335 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1336 pkgpart => $pkgpart,
1339 $error = $cust_pkg->insert( 'change' => $change );
1341 $dbh->rollback if $oldAutoCommit;
1344 push @$return_cust_pkg, $cust_pkg;
1346 # $return_cust_pkg now contains refs to all of the newly
1349 # Transfer services and cancel old packages.
1350 foreach my $old_pkg (@old_cust_pkg) {
1352 foreach my $new_pkg (@$return_cust_pkg) {
1353 $error = $old_pkg->transfer($new_pkg);
1354 if ($error and $error == 0) {
1355 # $old_pkg->transfer failed.
1356 $dbh->rollback if $oldAutoCommit;
1361 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1362 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1363 foreach my $new_pkg (@$return_cust_pkg) {
1364 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1365 if ($error and $error == 0) {
1366 # $old_pkg->transfer failed.
1367 $dbh->rollback if $oldAutoCommit;
1374 # Transfers were successful, but we went through all of the
1375 # new packages and still had services left on the old package.
1376 # We can't cancel the package under the circumstances, so abort.
1377 $dbh->rollback if $oldAutoCommit;
1378 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1380 $error = $old_pkg->cancel( quiet=>1 );
1386 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1394 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
1396 In sub order, the @pkgparts array (passed by reference) is clobbered.
1398 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
1399 method to pass dates to the recur_prog expression, it should do so.
1401 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1402 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1403 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1404 configuration values. Probably need a subroutine which decides what to do
1405 based on whether or not we've fetched the user yet, rather than a hash. See
1406 FS::UID and the TODO.
1408 Now that things are transactional should the check in the insert method be
1413 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1414 L<FS::pkg_svc>, schema.html from the base documentation