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;
18 use FS::cust_pkg_reason;
20 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
22 # because they load configuration by setting FS::UID::callback (see TODO)
28 # for sending cancel emails in sub cancel
31 @ISA = qw( FS::cust_main_Mixin FS::Record );
35 $disable_agentcheck = 0;
37 # The order in which to unprovision services.
38 @SVCDB_CANCEL_SEQ = qw( svc_external
47 my ( $hashref, $cache ) = @_;
48 #if ( $hashref->{'pkgpart'} ) {
49 if ( $hashref->{'pkg'} ) {
50 # #@{ $self->{'_pkgnum'} } = ();
51 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
52 # $self->{'_pkgpart'} = $subcache;
53 # #push @{ $self->{'_pkgnum'} },
54 # FS::part_pkg->new_or_cached($hashref, $subcache);
55 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
57 if ( exists $hashref->{'svcnum'} ) {
58 #@{ $self->{'_pkgnum'} } = ();
59 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
60 $self->{'_svcnum'} = $subcache;
61 #push @{ $self->{'_pkgnum'} },
62 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
68 FS::cust_pkg - Object methods for cust_pkg objects
74 $record = new FS::cust_pkg \%hash;
75 $record = new FS::cust_pkg { 'column' => 'value' };
77 $error = $record->insert;
79 $error = $new_record->replace($old_record);
81 $error = $record->delete;
83 $error = $record->check;
85 $error = $record->cancel;
87 $error = $record->suspend;
89 $error = $record->unsuspend;
91 $part_pkg = $record->part_pkg;
93 @labels = $record->labels;
95 $seconds = $record->seconds_since($timestamp);
97 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
98 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
102 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
103 inherits from FS::Record. The following fields are currently supported:
107 =item pkgnum - primary key (assigned automatically for new billing items)
109 =item custnum - Customer (see L<FS::cust_main>)
111 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
115 =item bill - date (next bill date)
117 =item last_bill - last bill date
125 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
127 =item manual_flag - If this field is set to 1, disables the automatic
128 unsuspension of this package when using the B<unsuspendauto> config file.
132 Note: setup, bill, susp, expire and cancel are specified as UNIX timestamps;
133 see L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for
134 conversion functions.
142 Create a new billing item. To add the item to the database, see L<"insert">.
146 sub table { 'cust_pkg'; }
147 sub cust_linked { $_[0]->cust_main_custnum; }
148 sub cust_unlinked_msg {
150 "WARNING: can't find cust_main.custnum ". $self->custnum.
151 ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
154 =item insert [ OPTION => VALUE ... ]
156 Adds this billing item to the database ("Orders" the item). If there is an
157 error, returns the error, otherwise returns false.
159 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
160 will be used to look up the package definition and agent restrictions will be
163 The following options are available: I<change>
165 I<change>, if set true, supresses any referral credit to a referring customer.
170 my( $self, %options ) = @_;
172 local $SIG{HUP} = 'IGNORE';
173 local $SIG{INT} = 'IGNORE';
174 local $SIG{QUIT} = 'IGNORE';
175 local $SIG{TERM} = 'IGNORE';
176 local $SIG{TSTP} = 'IGNORE';
177 local $SIG{PIPE} = 'IGNORE';
179 my $oldAutoCommit = $FS::UID::AutoCommit;
180 local $FS::UID::AutoCommit = 0;
183 my $error = $self->SUPER::insert;
185 $dbh->rollback if $oldAutoCommit;
189 #if ( $self->reg_code ) {
190 # my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
191 # $error = $reg_code->delete;
193 # $dbh->rollback if $oldAutoCommit;
198 my $conf = new FS::Conf;
199 my $cust_main = $self->cust_main;
200 my $part_pkg = $self->part_pkg;
201 if ( $conf->exists('referral_credit')
202 && $cust_main->referral_custnum
203 && ! $options{'change'}
204 && $part_pkg->freq !~ /^0\D?$/
207 my $referring_cust_main = $cust_main->referring_cust_main;
208 if ( $referring_cust_main->status ne 'cancelled' ) {
210 if ( $part_pkg->freq !~ /^\d+$/ ) {
211 warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum.
212 ' for package '. $self->pkgnum.
213 ' ( customer '. $self->custnum. ')'.
214 ' - One-time referral credits not (yet) available for '.
215 ' packages with '. $part_pkg->freq_pretty. ' frequency';
218 my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
220 $referring_cust_main->credit( $amount,
221 'Referral credit for '. $cust_main->name
224 $dbh->rollback if $oldAutoCommit;
225 return "Error crediting customer ". $cust_main->referral_custnum.
226 " for referral: $error";
234 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
241 This method now works but you probably shouldn't use it.
243 You don't want to delete billing items, because there would then be no record
244 the customer ever purchased the item. Instead, see the cancel method.
249 # return "Can't delete cust_pkg records!";
252 =item replace OLD_RECORD
254 Replaces the OLD_RECORD with this one in the database. If there is an error,
255 returns the error, otherwise returns false.
257 Currently, custnum, setup, bill, susp, expire, and cancel may be changed.
259 Changing pkgpart may have disasterous effects. See the order subroutine.
261 setup and bill are normally updated by calling the bill method of a customer
262 object (see L<FS::cust_main>).
264 suspend is normally updated by the suspend and unsuspend methods.
266 cancel is normally updated by the cancel method (and also the order subroutine
274 my( $new, $old, %options ) = @_;
276 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
277 return "Can't change otaker!" if $old->otaker ne $new->otaker;
280 #return "Can't change setup once it exists!"
281 # if $old->getfield('setup') &&
282 # $old->getfield('setup') != $new->getfield('setup');
284 #some logic for bill, susp, cancel?
286 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
288 local $SIG{HUP} = 'IGNORE';
289 local $SIG{INT} = 'IGNORE';
290 local $SIG{QUIT} = 'IGNORE';
291 local $SIG{TERM} = 'IGNORE';
292 local $SIG{TSTP} = 'IGNORE';
293 local $SIG{PIPE} = 'IGNORE';
295 my $oldAutoCommit = $FS::UID::AutoCommit;
296 local $FS::UID::AutoCommit = 0;
299 if ($options{'reason'} && $new->expire && $old->expire ne $new->expire) {
300 my $error = $new->insert_reason( 'reason' => $options{'reason'},
301 'date' => $new->expire,
304 dbh->rollback if $oldAutoCommit;
305 return "Error inserting cust_pkg_reason: $error";
309 #save off and freeze RADIUS attributes for any associated svc_acct records
311 if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
313 #also check for specific exports?
314 # to avoid spurious modify export events
315 @svc_acct = map { $_->svc_x }
316 grep { $_->part_svc->svcdb eq 'svc_acct' }
319 $_->snapshot foreach @svc_acct;
323 my $error = $new->SUPER::replace($old);
325 $dbh->rollback if $oldAutoCommit;
329 #for prepaid packages,
330 #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
331 foreach my $old_svc_acct ( @svc_acct ) {
332 my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
333 my $s_error = $new_svc_acct->replace($old_svc_acct);
335 $dbh->rollback if $oldAutoCommit;
340 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
347 Checks all fields to make sure this is a valid billing item. If there is an
348 error, returns the error, otherwise returns false. Called by the insert and
357 $self->ut_numbern('pkgnum')
358 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
359 || $self->ut_numbern('pkgpart')
360 || $self->ut_numbern('setup')
361 || $self->ut_numbern('bill')
362 || $self->ut_numbern('susp')
363 || $self->ut_numbern('cancel')
365 return $error if $error;
367 if ( $self->reg_code ) {
369 unless ( grep { $self->pkgpart == $_->pkgpart }
370 map { $_->reg_code_pkg }
371 qsearchs( 'reg_code', { 'code' => $self->reg_code,
372 'agentnum' => $self->cust_main->agentnum })
374 return "Unknown registration code";
377 } elsif ( $self->promo_code ) {
380 qsearchs('part_pkg', {
381 'pkgpart' => $self->pkgpart,
382 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
384 return 'Unknown promotional code' unless $promo_part_pkg;
388 unless ( $disable_agentcheck ) {
390 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
391 my $pkgpart_href = $agent->pkgpart_hashref;
392 return "agent ". $agent->agentnum.
393 " can't purchase pkgpart ". $self->pkgpart
394 unless $pkgpart_href->{ $self->pkgpart };
397 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
398 return $error if $error;
402 $self->otaker(getotaker) unless $self->otaker;
403 $self->otaker =~ /^([\w\.\-]{0,16})$/ or return "Illegal otaker";
406 if ( $self->dbdef_table->column('manual_flag') ) {
407 $self->manual_flag('') if $self->manual_flag eq ' ';
408 $self->manual_flag =~ /^([01]?)$/
409 or return "Illegal manual_flag ". $self->manual_flag;
410 $self->manual_flag($1);
416 =item cancel [ OPTION => VALUE ... ]
418 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
419 in this package, then cancels the package itself (sets the cancel field to
422 Available options are: I<quiet>
424 I<quiet> can be set true to supress email cancellation notices.
426 If there is an error, returns the error, otherwise returns false.
431 my( $self, %options ) = @_;
434 local $SIG{HUP} = 'IGNORE';
435 local $SIG{INT} = 'IGNORE';
436 local $SIG{QUIT} = 'IGNORE';
437 local $SIG{TERM} = 'IGNORE';
438 local $SIG{TSTP} = 'IGNORE';
439 local $SIG{PIPE} = 'IGNORE';
441 my $oldAutoCommit = $FS::UID::AutoCommit;
442 local $FS::UID::AutoCommit = 0;
445 if ($options{'reason'}) {
446 $error = $self->insert_reason( 'reason' => $options{'reason'} );
448 dbh->rollback if $oldAutoCommit;
449 return "Error inserting cust_pkg_reason: $error";
454 foreach my $cust_svc (
455 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
457 push @{ $svc{$cust_svc->part_svc->svcdb} }, $cust_svc;
460 foreach my $svcdb (@SVCDB_CANCEL_SEQ) {
461 foreach my $cust_svc (@{ $svc{$svcdb} }) {
462 my $error = $cust_svc->cancel;
465 $dbh->rollback if $oldAutoCommit;
466 return "Error cancelling cust_svc: $error";
471 # Add a credit for remaining service
472 my $remaining_value = $self->calc_remain();
473 if ( $remaining_value > 0 ) {
474 my $error = $self->cust_main->credit(
476 'Credit for unused time on '. $self->part_pkg->pkg,
479 $dbh->rollback if $oldAutoCommit;
480 return "Error crediting customer \$$remaining_value for unused time on".
481 $self->part_pkg->pkg. ": $error";
485 unless ( $self->getfield('cancel') ) {
486 my %hash = $self->hash;
487 $hash{'cancel'} = time;
488 my $new = new FS::cust_pkg ( \%hash );
489 $error = $new->replace($self);
491 $dbh->rollback if $oldAutoCommit;
496 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
498 my $conf = new FS::Conf;
499 my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
500 if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
501 my $conf = new FS::Conf;
502 my $error = send_email(
503 'from' => $conf->config('invoice_from'),
504 'to' => \@invoicing_list,
505 'subject' => $conf->config('cancelsubject'),
506 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
508 #should this do something on errors?
517 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
518 package, then suspends the package itself (sets the susp field to now).
520 If there is an error, returns the error, otherwise returns false.
525 my( $self, %options ) = @_;
528 local $SIG{HUP} = 'IGNORE';
529 local $SIG{INT} = 'IGNORE';
530 local $SIG{QUIT} = 'IGNORE';
531 local $SIG{TERM} = 'IGNORE';
532 local $SIG{TSTP} = 'IGNORE';
533 local $SIG{PIPE} = 'IGNORE';
535 my $oldAutoCommit = $FS::UID::AutoCommit;
536 local $FS::UID::AutoCommit = 0;
539 if ($options{'reason'}) {
540 $error = $self->insert_reason( 'reason' => $options{'reason'} );
542 dbh->rollback if $oldAutoCommit;
543 return "Error inserting cust_pkg_reason: $error";
547 foreach my $cust_svc (
548 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
550 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
552 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
553 $dbh->rollback if $oldAutoCommit;
554 return "Illegal svcdb value in part_svc!";
557 require "FS/$svcdb.pm";
559 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
561 $error = $svc->suspend;
563 $dbh->rollback if $oldAutoCommit;
570 unless ( $self->getfield('susp') ) {
571 my %hash = $self->hash;
572 $hash{'susp'} = time;
573 my $new = new FS::cust_pkg ( \%hash );
574 $error = $new->replace($self);
576 $dbh->rollback if $oldAutoCommit;
581 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
586 =item unsuspend [ OPTION => VALUE ... ]
588 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
589 package, then unsuspends the package itself (clears the susp field).
591 Available options are: I<adjust_next_bill>.
593 I<adjust_next_bill> can be set true to adjust the next bill date forward by
594 the amount of time the account was inactive. This was set true by default
595 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
596 explicitly requested. Price plans for which this makes sense (anniversary-date
597 based than prorate or subscription) could have an option to enable this
600 If there is an error, returns the error, otherwise returns false.
605 my( $self, %opt ) = @_;
608 local $SIG{HUP} = 'IGNORE';
609 local $SIG{INT} = 'IGNORE';
610 local $SIG{QUIT} = 'IGNORE';
611 local $SIG{TERM} = 'IGNORE';
612 local $SIG{TSTP} = 'IGNORE';
613 local $SIG{PIPE} = 'IGNORE';
615 my $oldAutoCommit = $FS::UID::AutoCommit;
616 local $FS::UID::AutoCommit = 0;
619 foreach my $cust_svc (
620 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
622 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
624 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
625 $dbh->rollback if $oldAutoCommit;
626 return "Illegal svcdb value in part_svc!";
629 require "FS/$svcdb.pm";
631 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
633 $error = $svc->unsuspend;
635 $dbh->rollback if $oldAutoCommit;
642 unless ( ! $self->getfield('susp') ) {
643 my %hash = $self->hash;
644 my $inactive = time - $hash{'susp'};
646 my $conf = new FS::Conf;
648 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
649 if ( $opt{'adjust_next_bill'}
650 || $conf->config('unsuspend-always_adjust_next_bill_date') )
651 && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
654 my $new = new FS::cust_pkg ( \%hash );
655 $error = $new->replace($self);
657 $dbh->rollback if $oldAutoCommit;
662 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
669 Returns the last bill date, or if there is no last bill date, the setup date.
670 Useful for billing metered services.
676 if ( $self->dbdef_table->column('last_bill') ) {
677 return $self->setfield('last_bill', $_[0]) if @_;
678 return $self->getfield('last_bill') if $self->getfield('last_bill');
680 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
681 'edate' => $self->bill, } );
682 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
687 Returns the most recent FS::reason associated with the package.
693 my $cust_pkg_reason = qsearchs( {
694 'table' => 'cust_pkg_reason',
695 'hashref' => { 'pkgnum' => $self->pkgnum, },
696 'extra_sql'=> 'ORDER BY date DESC',
698 qsearchs ( 'reason', { 'reasonnum' => $cust_pkg_reason->reasonnum } )
704 Returns the definition for this billing item, as an FS::part_pkg object (see
711 #exists( $self->{'_pkgpart'} )
713 ? $self->{'_pkgpart'}
714 : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
719 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
726 $self->part_pkg->calc_setup($self, @_);
731 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
738 $self->part_pkg->calc_recur($self, @_);
743 Calls the I<calc_remain> of the FS::part_pkg object associated with this
750 $self->part_pkg->calc_remain($self, @_);
755 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
762 $self->part_pkg->calc_cancel($self, @_);
765 =item cust_svc [ SVCPART ]
767 Returns the services for this package, as FS::cust_svc objects (see
768 L<FS::cust_svc>). If a svcpart is specified, return only the matching
777 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
778 'svcpart' => shift, } );
781 #if ( $self->{'_svcnum'} ) {
782 # values %{ $self->{'_svcnum'}->cache };
784 $self->_sort_cust_svc(
785 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
791 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
793 Returns historical services for this package created before END TIMESTAMP and
794 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
795 (see L<FS::h_cust_svc>).
802 $self->_sort_cust_svc(
803 [ qsearch( 'h_cust_svc',
804 { 'pkgnum' => $self->pkgnum, },
805 FS::h_cust_svc->sql_h_search(@_),
812 my( $self, $arrayref ) = @_;
815 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
817 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
818 'svcpart' => $_->svcpart } );
820 $pkg_svc ? $pkg_svc->primary_svc : '',
821 $pkg_svc ? $pkg_svc->quantity : 0,
828 =item num_cust_svc [ SVCPART ]
830 Returns the number of provisioned services for this package. If a svcpart is
831 specified, counts only the matching services.
837 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
838 $sql .= ' AND svcpart = ?' if @_;
839 my $sth = dbh->prepare($sql) or die dbh->errstr;
840 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
841 $sth->fetchrow_arrayref->[0];
844 =item available_part_svc
846 Returns a list FS::part_svc objects representing services included in this
847 package but not yet provisioned. Each FS::part_svc object also has an extra
848 field, I<num_avail>, which specifies the number of available services.
852 sub available_part_svc {
854 grep { $_->num_avail > 0 }
856 my $part_svc = $_->part_svc;
857 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
858 $_->quantity - $self->num_cust_svc($_->svcpart);
861 $self->part_pkg->pkg_svc;
866 Returns a short status string for this package, currently:
872 =item one-time charge
887 my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
889 return 'cancelled' if $self->get('cancel');
890 return 'suspended' if $self->susp;
891 return 'not yet billed' unless $self->setup;
892 return 'one-time charge' if $freq =~ /^(0|$)/;
898 Class method that returns the list of possible status strings for pacakges
899 (see L<the status method|/status>). For example:
901 @statuses = FS::cust_pkg->statuses();
905 tie my %statuscolor, 'Tie::IxHash',
906 'not yet billed' => '000000',
907 'one-time charge' => '000000',
908 'active' => '00CC00',
909 'suspended' => 'FF9900',
910 'cancelled' => 'FF0000',
914 my $self = shift; #could be class...
915 grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
916 # mayble split btw one-time vs. recur
922 Returns a hex triplet color string for this package's status.
928 $statuscolor{$self->status};
933 Returns a list of lists, calling the label method for all services
934 (see L<FS::cust_svc>) of this billing item.
940 map { [ $_->label ] } $self->cust_svc;
943 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
945 Like the labels method, but returns historical information on services that
946 were active as of END_TIMESTAMP and (optionally) not cancelled before
949 Returns a list of lists, calling the label method for all (historical) services
950 (see L<FS::h_cust_svc>) of this billing item.
956 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
959 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
961 Like h_labels, except returns a simple flat list, and shortens long
962 (currently >5) lists of identical services to one line that lists the service
963 label and the number of individual services rather than individual items.
971 #tie %labels, 'Tie::IxHash';
972 push @{ $labels{$_->[0]} }, $_->[1]
973 foreach $self->h_labels(@_);
975 foreach my $label ( keys %labels ) {
976 my @values = @{ $labels{$label} };
977 my $num = scalar(@values);
979 push @labels, "$label ($num)";
981 push @labels, map { "$label: $_" } @values;
991 Returns the parent customer object (see L<FS::cust_main>).
997 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1000 =item seconds_since TIMESTAMP
1002 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1003 package have been online since TIMESTAMP, according to the session monitor.
1005 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1006 L<Time::Local> and L<Date::Parse> for conversion functions.
1011 my($self, $since) = @_;
1014 foreach my $cust_svc (
1015 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1017 $seconds += $cust_svc->seconds_since($since);
1024 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1026 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1027 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1030 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1031 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1037 sub seconds_since_sqlradacct {
1038 my($self, $start, $end) = @_;
1042 foreach my $cust_svc (
1044 my $part_svc = $_->part_svc;
1045 $part_svc->svcdb eq 'svc_acct'
1046 && scalar($part_svc->part_export('sqlradius'));
1049 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1056 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1058 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1059 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1063 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1064 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1069 sub attribute_since_sqlradacct {
1070 my($self, $start, $end, $attrib) = @_;
1074 foreach my $cust_svc (
1076 my $part_svc = $_->part_svc;
1077 $part_svc->svcdb eq 'svc_acct'
1078 && scalar($part_svc->part_export('sqlradius'));
1081 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1088 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1090 Transfers as many services as possible from this package to another package.
1092 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1093 object. The destination package must already exist.
1095 Services are moved only if the destination allows services with the correct
1096 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
1097 this option with caution! No provision is made for export differences
1098 between the old and new service definitions. Probably only should be used
1099 when your exports for all service definitions of a given svcdb are identical.
1100 (attempt a transfer without it first, to move all possible svcpart-matching
1103 Any services that can't be moved remain in the original package.
1105 Returns an error, if there is one; otherwise, returns the number of services
1106 that couldn't be moved.
1111 my ($self, $dest_pkgnum, %opt) = @_;
1117 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1118 $dest = $dest_pkgnum;
1119 $dest_pkgnum = $dest->pkgnum;
1121 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1124 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1126 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1127 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1130 foreach my $cust_svc ($dest->cust_svc) {
1131 $target{$cust_svc->svcpart}--;
1134 my %svcpart2svcparts = ();
1135 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1136 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1137 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1138 next if exists $svcpart2svcparts{$svcpart};
1139 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1140 $svcpart2svcparts{$svcpart} = [
1142 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
1144 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1145 'svcpart' => $_ } );
1147 $pkg_svc ? $pkg_svc->primary_svc : '',
1148 $pkg_svc ? $pkg_svc->quantity : 0,
1152 grep { $_ != $svcpart }
1154 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1156 warn "alternates for svcpart $svcpart: ".
1157 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1162 foreach my $cust_svc ($self->cust_svc) {
1163 if($target{$cust_svc->svcpart} > 0) {
1164 $target{$cust_svc->svcpart}--;
1165 my $new = new FS::cust_svc {
1166 svcnum => $cust_svc->svcnum,
1167 svcpart => $cust_svc->svcpart,
1168 pkgnum => $dest_pkgnum,
1170 my $error = $new->replace($cust_svc);
1171 return $error if $error;
1172 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1174 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1175 warn "alternates to consider: ".
1176 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1178 my @alternate = grep {
1179 warn "considering alternate svcpart $_: ".
1180 "$target{$_} available in new package\n"
1183 } @{$svcpart2svcparts{$cust_svc->svcpart}};
1185 warn "alternate(s) found\n" if $DEBUG;
1186 my $change_svcpart = $alternate[0];
1187 $target{$change_svcpart}--;
1188 my $new = new FS::cust_svc {
1189 svcnum => $cust_svc->svcnum,
1190 svcpart => $change_svcpart,
1191 pkgnum => $dest_pkgnum,
1193 my $error = $new->replace($cust_svc);
1194 return $error if $error;
1207 This method is deprecated. See the I<depend_jobnum> option to the insert and
1208 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1215 local $SIG{HUP} = 'IGNORE';
1216 local $SIG{INT} = 'IGNORE';
1217 local $SIG{QUIT} = 'IGNORE';
1218 local $SIG{TERM} = 'IGNORE';
1219 local $SIG{TSTP} = 'IGNORE';
1220 local $SIG{PIPE} = 'IGNORE';
1222 my $oldAutoCommit = $FS::UID::AutoCommit;
1223 local $FS::UID::AutoCommit = 0;
1226 foreach my $cust_svc ( $self->cust_svc ) {
1227 #false laziness w/svc_Common::insert
1228 my $svc_x = $cust_svc->svc_x;
1229 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1230 my $error = $part_export->export_insert($svc_x);
1232 $dbh->rollback if $oldAutoCommit;
1238 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1245 =head1 CLASS METHODS
1251 Returns an SQL expression identifying recurring packages.
1255 sub recurring_sql { "
1256 '0' != ( select freq from part_pkg
1257 where cust_pkg.pkgpart = part_pkg.pkgpart )
1262 Returns an SQL expression identifying one-time packages.
1267 '0' = ( select freq from part_pkg
1268 where cust_pkg.pkgpart = part_pkg.pkgpart )
1273 Returns an SQL expression identifying active packages.
1278 ". $_[0]->recurring_sql(). "
1279 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1280 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1285 Returns an SQL expression identifying inactive packages (one-time packages
1286 that are otherwise unsuspended/uncancelled).
1290 sub inactive_sql { "
1291 ". $_[0]->onetime_sql(). "
1292 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1293 AND ( cust_pkg.susp IS NULL OR cust_pkg.susp = 0 )
1299 Returns an SQL expression identifying suspended packages.
1303 sub suspended_sql { susp_sql(@_); }
1305 #$_[0]->recurring_sql(). ' AND '.
1307 ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1308 AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
1315 Returns an SQL exprression identifying cancelled packages.
1319 sub cancelled_sql { cancel_sql(@_); }
1321 #$_[0]->recurring_sql(). ' AND '.
1322 "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1329 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1331 CUSTNUM is a customer (see L<FS::cust_main>)
1333 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1334 L<FS::part_pkg>) to order for this customer. Duplicates are of course
1337 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1338 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
1339 new billing items. An error is returned if this is not possible (see
1340 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
1343 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1344 newly-created cust_pkg objects.
1349 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1351 my $conf = new FS::Conf;
1353 # Transactionize this whole mess
1354 local $SIG{HUP} = 'IGNORE';
1355 local $SIG{INT} = 'IGNORE';
1356 local $SIG{QUIT} = 'IGNORE';
1357 local $SIG{TERM} = 'IGNORE';
1358 local $SIG{TSTP} = 'IGNORE';
1359 local $SIG{PIPE} = 'IGNORE';
1361 my $oldAutoCommit = $FS::UID::AutoCommit;
1362 local $FS::UID::AutoCommit = 0;
1366 my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1367 return "Customer not found: $custnum" unless $cust_main;
1369 my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1372 my $change = scalar(@old_cust_pkg) != 0;
1375 if ( scalar(@old_cust_pkg) == 1 ) {
1376 #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1377 $hash{'setup'} = time;
1380 # Create the new packages.
1381 foreach my $pkgpart (@$pkgparts) {
1382 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1383 pkgpart => $pkgpart,
1386 $error = $cust_pkg->insert( 'change' => $change );
1388 $dbh->rollback if $oldAutoCommit;
1391 push @$return_cust_pkg, $cust_pkg;
1393 # $return_cust_pkg now contains refs to all of the newly
1396 # Transfer services and cancel old packages.
1397 foreach my $old_pkg (@old_cust_pkg) {
1399 foreach my $new_pkg (@$return_cust_pkg) {
1400 $error = $old_pkg->transfer($new_pkg);
1401 if ($error and $error == 0) {
1402 # $old_pkg->transfer failed.
1403 $dbh->rollback if $oldAutoCommit;
1408 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1409 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1410 foreach my $new_pkg (@$return_cust_pkg) {
1411 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1412 if ($error and $error == 0) {
1413 # $old_pkg->transfer failed.
1414 $dbh->rollback if $oldAutoCommit;
1421 # Transfers were successful, but we went through all of the
1422 # new packages and still had services left on the old package.
1423 # We can't cancel the package under the circumstances, so abort.
1424 $dbh->rollback if $oldAutoCommit;
1425 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1427 $error = $old_pkg->cancel( quiet=>1 );
1433 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1438 my ($self, %options) = @_;
1440 my $otaker = $FS::CurrentUser::CurrentUser->name;
1441 $otaker = $FS::CurrentUser::CurrentUser->username
1442 if (($otaker) eq "User, Legacy");
1444 my $cust_pkg_reason =
1445 new FS::cust_pkg_reason({ 'pkgnum' => $self->pkgnum,
1446 'reasonnum' => $options{'reason'},
1447 'otaker' => $otaker,
1448 'date' => $options{'date'}
1452 return $cust_pkg_reason->insert;
1459 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
1461 In sub order, the @pkgparts array (passed by reference) is clobbered.
1463 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
1464 method to pass dates to the recur_prog expression, it should do so.
1466 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1467 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1468 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1469 configuration values. Probably need a subroutine which decides what to do
1470 based on whether or not we've fetched the user yet, rather than a hash. See
1471 FS::UID and the TODO.
1473 Now that things are transactional should the check in the insert method be
1478 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1479 L<FS::pkg_svc>, schema.html from the base documentation