4 use vars qw(@ISA $disable_agentcheck @SVCDB_CANCEL_SEQ $DEBUG);
5 use FS::UID qw( getotaker dbh );
6 use FS::Record qw( qsearch qsearchs );
7 use FS::Misc qw( send_email );
13 use FS::cust_bill_pkg;
16 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
18 # because they load configuraion by setting FS::UID::callback (see TODO)
24 # for sending cancel emails in sub cancel
27 @ISA = qw( FS::Record );
31 $disable_agentcheck = 0;
33 # The order in which to unprovision services.
34 @SVCDB_CANCEL_SEQ = qw( svc_external
43 my ( $hashref, $cache ) = @_;
44 #if ( $hashref->{'pkgpart'} ) {
45 if ( $hashref->{'pkg'} ) {
46 # #@{ $self->{'_pkgnum'} } = ();
47 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
48 # $self->{'_pkgpart'} = $subcache;
49 # #push @{ $self->{'_pkgnum'} },
50 # FS::part_pkg->new_or_cached($hashref, $subcache);
51 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
53 if ( exists $hashref->{'svcnum'} ) {
54 #@{ $self->{'_pkgnum'} } = ();
55 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
56 $self->{'_svcnum'} = $subcache;
57 #push @{ $self->{'_pkgnum'} },
58 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
64 FS::cust_pkg - Object methods for cust_pkg objects
70 $record = new FS::cust_pkg \%hash;
71 $record = new FS::cust_pkg { 'column' => 'value' };
73 $error = $record->insert;
75 $error = $new_record->replace($old_record);
77 $error = $record->delete;
79 $error = $record->check;
81 $error = $record->cancel;
83 $error = $record->suspend;
85 $error = $record->unsuspend;
87 $part_pkg = $record->part_pkg;
89 @labels = $record->labels;
91 $seconds = $record->seconds_since($timestamp);
93 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
94 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
98 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
99 inherits from FS::Record. The following fields are currently supported:
103 =item pkgnum - primary key (assigned automatically for new billing items)
105 =item custnum - Customer (see L<FS::cust_main>)
107 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
111 =item bill - date (next bill date)
113 =item last_bill - last bill date
121 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
123 =item manual_flag - If this field is set to 1, disables the automatic
124 unsuspension of this package when using the B<unsuspendauto> config file.
128 Note: setup, bill, susp, expire and cancel are specified as UNIX timestamps;
129 see L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for
130 conversion functions.
138 Create a new billing item. To add the item to the database, see L<"insert">.
142 sub table { 'cust_pkg'; }
144 =item insert [ OPTION => VALUE ... ]
146 Adds this billing item to the database ("Orders" the item). If there is an
147 error, returns the error, otherwise returns false.
149 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
150 will be used to look up the package definition and agent restrictions will be
153 The following options are available: I<change>
155 I<change>, if set true, supresses any referral credit to a referring customer.
160 my( $self, %options ) = @_;
162 local $SIG{HUP} = 'IGNORE';
163 local $SIG{INT} = 'IGNORE';
164 local $SIG{QUIT} = 'IGNORE';
165 local $SIG{TERM} = 'IGNORE';
166 local $SIG{TSTP} = 'IGNORE';
167 local $SIG{PIPE} = 'IGNORE';
169 my $oldAutoCommit = $FS::UID::AutoCommit;
170 local $FS::UID::AutoCommit = 0;
173 my $error = $self->SUPER::insert;
175 $dbh->rollback if $oldAutoCommit;
179 my $conf = new FS::Conf;
180 my $cust_main = $self->cust_main;
181 my $part_pkg = $self->part_pkg;
182 if ( $conf->exists('referral_credit')
183 && $cust_main->referral_custnum
184 && ! $options{'change'}
185 && $part_pkg->freq !~ /^0\D?$/
188 my $referring_cust_main = $cust_main->referring_cust_main;
189 if ( $referring_cust_main->status ne 'cancelled' ) {
191 if ( $part_pkg->freq !~ /^\d+$/ ) {
192 warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum.
193 ' for package '. $self->pkgnum.
194 ' ( customer '. $self->custnum. ')'.
195 ' - One-time referral credits not (yet) available for '.
196 ' packages with '. $part_pkg->freq_pretty. ' frequency';
199 my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
201 $referring_cust_main->credit( $amount,
202 'Referral credit for '. $cust_main->name
205 $dbh->rollback if $oldAutoCommit;
206 return "Error crediting customer ". $cust_main->referral_custnum.
207 " for referral: $error";
215 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
222 This method now works but you probably shouldn't use it.
224 You don't want to delete billing items, because there would then be no record
225 the customer ever purchased the item. Instead, see the cancel method.
230 # return "Can't delete cust_pkg records!";
233 =item replace OLD_RECORD
235 Replaces the OLD_RECORD with this one in the database. If there is an error,
236 returns the error, otherwise returns false.
238 Currently, custnum, setup, bill, susp, expire, and cancel may be changed.
240 Changing pkgpart may have disasterous effects. See the order subroutine.
242 setup and bill are normally updated by calling the bill method of a customer
243 object (see L<FS::cust_main>).
245 suspend is normally updated by the suspend and unsuspend methods.
247 cancel is normally updated by the cancel method (and also the order subroutine
253 my( $new, $old ) = ( shift, shift );
255 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
256 return "Can't change otaker!" if $old->otaker ne $new->otaker;
259 #return "Can't change setup once it exists!"
260 # if $old->getfield('setup') &&
261 # $old->getfield('setup') != $new->getfield('setup');
263 #some logic for bill, susp, cancel?
265 local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
267 $new->SUPER::replace($old);
272 Checks all fields to make sure this is a valid billing item. If there is an
273 error, returns the error, otherwise returns false. Called by the insert and
282 $self->ut_numbern('pkgnum')
283 || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
284 || $self->ut_numbern('pkgpart')
285 || $self->ut_numbern('setup')
286 || $self->ut_numbern('bill')
287 || $self->ut_numbern('susp')
288 || $self->ut_numbern('cancel')
290 return $error if $error;
292 if ( $self->promo_code ) {
295 qsearchs('part_pkg', {
296 'pkgpart' => $self->pkgpart,
297 'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
299 return 'Unknown promotional code' unless $promo_part_pkg;
300 $self->pkgpart($promo_part_pkg->pkgpart);
304 unless ( $disable_agentcheck ) {
306 qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
307 my $pkgpart_href = $agent->pkgpart_hashref;
308 return "agent ". $agent->agentnum.
309 " can't purchase pkgpart ". $self->pkgpart
310 unless $pkgpart_href->{ $self->pkgpart };
313 $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
314 return $error if $error;
318 $self->otaker(getotaker) unless $self->otaker;
319 $self->otaker =~ /^([\w\.\-]{0,16})$/ or return "Illegal otaker";
322 if ( $self->dbdef_table->column('manual_flag') ) {
323 $self->manual_flag('') if $self->manual_flag eq ' ';
324 $self->manual_flag =~ /^([01]?)$/
325 or return "Illegal manual_flag ". $self->manual_flag;
326 $self->manual_flag($1);
332 =item cancel [ OPTION => VALUE ... ]
334 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
335 in this package, then cancels the package itself (sets the cancel field to
338 Available options are: I<quiet>
340 I<quiet> can be set true to supress email cancellation notices.
342 If there is an error, returns the error, otherwise returns false.
347 my( $self, %options ) = @_;
350 local $SIG{HUP} = 'IGNORE';
351 local $SIG{INT} = 'IGNORE';
352 local $SIG{QUIT} = 'IGNORE';
353 local $SIG{TERM} = 'IGNORE';
354 local $SIG{TSTP} = 'IGNORE';
355 local $SIG{PIPE} = 'IGNORE';
357 my $oldAutoCommit = $FS::UID::AutoCommit;
358 local $FS::UID::AutoCommit = 0;
362 foreach my $cust_svc (
363 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
365 push @{ $svc{$cust_svc->part_svc->svcdb} }, $cust_svc;
368 foreach my $svcdb (@SVCDB_CANCEL_SEQ) {
369 foreach my $cust_svc (@{ $svc{$svcdb} }) {
370 my $error = $cust_svc->cancel;
373 $dbh->rollback if $oldAutoCommit;
374 return "Error cancelling cust_svc: $error";
379 # Add a credit for remaining service
380 my $remaining_value= $self->calc_remain();
381 if ($remaining_value > 0) {
382 my $error = $self->credit($remaining_value, 'Credit for service remaining');
384 $dbh->rollback if $oldAutoCommit;
385 return "Error crediting customer for service remaining: $error";
389 unless ( $self->getfield('cancel') ) {
390 my %hash = $self->hash;
391 $hash{'cancel'} = time;
392 my $new = new FS::cust_pkg ( \%hash );
393 $error = $new->replace($self);
395 $dbh->rollback if $oldAutoCommit;
400 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
402 my $conf = new FS::Conf;
403 my @invoicing_list = grep { $_ ne 'POST' } $self->cust_main->invoicing_list;
404 if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
405 my $conf = new FS::Conf;
406 my $error = send_email(
407 'from' => $conf->config('invoice_from'),
408 'to' => \@invoicing_list,
409 'subject' => $conf->config('cancelsubject'),
410 'body' => [ map "$_\n", $conf->config('cancelmessage') ],
412 #should this do something on errors?
421 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
422 package, then suspends the package itself (sets the susp field to now).
424 If there is an error, returns the error, otherwise returns false.
432 local $SIG{HUP} = 'IGNORE';
433 local $SIG{INT} = 'IGNORE';
434 local $SIG{QUIT} = 'IGNORE';
435 local $SIG{TERM} = 'IGNORE';
436 local $SIG{TSTP} = 'IGNORE';
437 local $SIG{PIPE} = 'IGNORE';
439 my $oldAutoCommit = $FS::UID::AutoCommit;
440 local $FS::UID::AutoCommit = 0;
443 foreach my $cust_svc (
444 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
446 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
448 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
449 $dbh->rollback if $oldAutoCommit;
450 return "Illegal svcdb value in part_svc!";
453 require "FS/$svcdb.pm";
455 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
457 $error = $svc->suspend;
459 $dbh->rollback if $oldAutoCommit;
466 unless ( $self->getfield('susp') ) {
467 my %hash = $self->hash;
468 $hash{'susp'} = 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;
484 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
485 package, then unsuspends the package itself (clears the susp field).
487 If there is an error, returns the error, otherwise returns false.
495 local $SIG{HUP} = 'IGNORE';
496 local $SIG{INT} = 'IGNORE';
497 local $SIG{QUIT} = 'IGNORE';
498 local $SIG{TERM} = 'IGNORE';
499 local $SIG{TSTP} = 'IGNORE';
500 local $SIG{PIPE} = 'IGNORE';
502 my $oldAutoCommit = $FS::UID::AutoCommit;
503 local $FS::UID::AutoCommit = 0;
506 foreach my $cust_svc (
507 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
509 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
511 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
512 $dbh->rollback if $oldAutoCommit;
513 return "Illegal svcdb value in part_svc!";
516 require "FS/$svcdb.pm";
518 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
520 $error = $svc->unsuspend;
522 $dbh->rollback if $oldAutoCommit;
529 unless ( ! $self->getfield('susp') ) {
530 my %hash = $self->hash;
531 my $inactive = time - $hash{'susp'};
533 $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
534 if $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
535 my $new = new FS::cust_pkg ( \%hash );
536 $error = $new->replace($self);
538 $dbh->rollback if $oldAutoCommit;
543 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
550 Returns the last bill date, or if there is no last bill date, the setup date.
551 Useful for billing metered services.
557 if ( $self->dbdef_table->column('last_bill') ) {
558 return $self->setfield('last_bill', $_[0]) if @_;
559 return $self->getfield('last_bill') if $self->getfield('last_bill');
561 my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
562 'edate' => $self->bill, } );
563 $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
568 Returns the definition for this billing item, as an FS::part_pkg object (see
575 #exists( $self->{'_pkgpart'} )
577 ? $self->{'_pkgpart'}
578 : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
583 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
590 $self->part_pkg->calc_setup($self, @_);
595 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
602 $self->part_pkg->calc_recur($self, @_);
607 Calls the I<calc_remain> of the FS::part_pkg object associated with this
614 $self->part_pkg->calc_remain($self, @_);
619 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
626 $self->part_pkg->calc_cancel($self, @_);
629 =item cust_svc [ SVCPART ]
631 Returns the services for this package, as FS::cust_svc objects (see
632 L<FS::cust_svc>). If a svcpart is specified, return only the matching
641 return qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum,
642 'svcpart' => shift, } );
645 #if ( $self->{'_svcnum'} ) {
646 # values %{ $self->{'_svcnum'}->cache };
648 $self->_sort_cust_svc(
649 [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
655 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
657 Returns historical services for this package created before END TIMESTAMP and
658 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
659 (see L<FS::h_cust_svc>).
666 $self->_sort_cust_svc(
667 [ qsearch( 'h_cust_svc',
668 { 'pkgnum' => $self->pkgnum, },
669 FS::h_cust_svc->sql_h_search(@_),
676 my( $self, $arrayref ) = @_;
679 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
681 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
682 'svcpart' => $_->svcpart } );
684 $pkg_svc ? $pkg_svc->primary_svc : '',
685 $pkg_svc ? $pkg_svc->quantity : 0,
692 =item num_cust_svc [ SVCPART ]
694 Returns the number of provisioned services for this package. If a svcpart is
695 specified, counts only the matching services.
701 my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
702 $sql .= ' AND svcpart = ?' if @_;
703 my $sth = dbh->prepare($sql) or die dbh->errstr;
704 $sth->execute($self->pkgnum, @_) or die $sth->errstr;
705 $sth->fetchrow_arrayref->[0];
708 =item available_part_svc
710 Returns a list FS::part_svc objects representing services included in this
711 package but not yet provisioned. Each FS::part_svc object also has an extra
712 field, I<num_avail>, which specifies the number of available services.
716 sub available_part_svc {
718 grep { $_->num_avail > 0 }
720 my $part_svc = $_->part_svc;
721 $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
722 $_->quantity - $self->num_cust_svc($_->svcpart);
725 $self->part_pkg->pkg_svc;
730 Returns a list of lists, calling the label method for all services
731 (see L<FS::cust_svc>) of this billing item.
737 map { [ $_->label ] } $self->cust_svc;
740 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
742 Like the labels method, but returns historical information on services that
743 were active as of END_TIMESTAMP and (optionally) not cancelled before
746 Returns a list of lists, calling the label method for all (historical) services
747 (see L<FS::h_cust_svc>) of this billing item.
753 map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
756 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
758 Like h_labels, except returns a simple flat list, and shortens long
759 (currently >5) lists of identical services to one line that lists the service
760 label and the number of individual services rather than individual items.
768 #tie %labels, 'Tie::IxHash';
769 push @{ $labels{$_->[0]} }, $_->[1]
770 foreach $self->h_labels(@_);
772 foreach my $label ( keys %labels ) {
773 my @values = @{ $labels{$label} };
774 my $num = scalar(@values);
776 push @labels, "$label ($num)";
778 push @labels, map { "$label: $_" } @values;
788 Returns the parent customer object (see L<FS::cust_main>).
794 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
797 =item seconds_since TIMESTAMP
799 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
800 package have been online since TIMESTAMP, according to the session monitor.
802 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
803 L<Time::Local> and L<Date::Parse> for conversion functions.
808 my($self, $since) = @_;
811 foreach my $cust_svc (
812 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
814 $seconds += $cust_svc->seconds_since($since);
821 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
823 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
824 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
827 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
828 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
834 sub seconds_since_sqlradacct {
835 my($self, $start, $end) = @_;
839 foreach my $cust_svc (
841 my $part_svc = $_->part_svc;
842 $part_svc->svcdb eq 'svc_acct'
843 && scalar($part_svc->part_export('sqlradius'));
846 $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
853 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
855 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
856 in this package for sessions ending between TIMESTAMP_START (inclusive) and
860 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
861 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
866 sub attribute_since_sqlradacct {
867 my($self, $start, $end, $attrib) = @_;
871 foreach my $cust_svc (
873 my $part_svc = $_->part_svc;
874 $part_svc->svcdb eq 'svc_acct'
875 && scalar($part_svc->part_export('sqlradius'));
878 $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
885 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
887 Transfers as many services as possible from this package to another package.
889 The destination package can be specified by pkgnum by passing an FS::cust_pkg
890 object. The destination package must already exist.
892 Services are moved only if the destination allows services with the correct
893 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true. Use
894 this option with caution! No provision is made for export differences
895 between the old and new service definitions. Probably only should be used
896 when your exports for all service definitions of a given svcdb are identical.
897 (attempt a transfer without it first, to move all possible svcpart-matching
900 Any services that can't be moved remain in the original package.
902 Returns an error, if there is one; otherwise, returns the number of services
903 that couldn't be moved.
908 my ($self, $dest_pkgnum, %opt) = @_;
914 if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
915 $dest = $dest_pkgnum;
916 $dest_pkgnum = $dest->pkgnum;
918 $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
921 return ('Package does not exist: '.$dest_pkgnum) unless $dest;
923 foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
924 $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
927 foreach my $cust_svc ($dest->cust_svc) {
928 $target{$cust_svc->svcpart}--;
931 my %svcpart2svcparts = ();
932 if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
933 warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
934 foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
935 next if exists $svcpart2svcparts{$svcpart};
936 my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
937 $svcpart2svcparts{$svcpart} = [
939 sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] }
941 my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
944 $pkg_svc ? $pkg_svc->primary_svc : '',
945 $pkg_svc ? $pkg_svc->quantity : 0,
949 grep { $_ != $svcpart }
951 qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
953 warn "alternates for svcpart $svcpart: ".
954 join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
959 foreach my $cust_svc ($self->cust_svc) {
960 if($target{$cust_svc->svcpart} > 0) {
961 $target{$cust_svc->svcpart}--;
962 my $new = new FS::cust_svc {
963 svcnum => $cust_svc->svcnum,
964 svcpart => $cust_svc->svcpart,
965 pkgnum => $dest_pkgnum,
967 my $error = $new->replace($cust_svc);
968 return $error if $error;
969 } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
971 warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
972 warn "alternates to consider: ".
973 join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
975 my @alternate = grep {
976 warn "considering alternate svcpart $_: ".
977 "$target{$_} available in new package\n"
980 } @{$svcpart2svcparts{$cust_svc->svcpart}};
982 warn "alternate(s) found\n" if $DEBUG;
983 my $change_svcpart = $alternate[0];
984 $target{$change_svcpart}--;
985 my $new = new FS::cust_svc {
986 svcnum => $cust_svc->svcnum,
987 svcpart => $change_svcpart,
988 pkgnum => $dest_pkgnum,
990 my $error = $new->replace($cust_svc);
991 return $error if $error;
1004 This method is deprecated. See the I<depend_jobnum> option to the insert and
1005 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1012 local $SIG{HUP} = 'IGNORE';
1013 local $SIG{INT} = 'IGNORE';
1014 local $SIG{QUIT} = 'IGNORE';
1015 local $SIG{TERM} = 'IGNORE';
1016 local $SIG{TSTP} = 'IGNORE';
1017 local $SIG{PIPE} = 'IGNORE';
1019 my $oldAutoCommit = $FS::UID::AutoCommit;
1020 local $FS::UID::AutoCommit = 0;
1023 foreach my $cust_svc ( $self->cust_svc ) {
1024 #false laziness w/svc_Common::insert
1025 my $svc_x = $cust_svc->svc_x;
1026 foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1027 my $error = $part_export->export_insert($svc_x);
1029 $dbh->rollback if $oldAutoCommit;
1035 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1046 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1048 CUSTNUM is a customer (see L<FS::cust_main>)
1050 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1051 L<FS::part_pkg>) to order for this customer. Duplicates are of course
1054 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1055 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
1056 new billing items. An error is returned if this is not possible (see
1057 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
1060 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1061 newly-created cust_pkg objects.
1066 my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1068 my $conf = new FS::Conf;
1070 # Transactionize this whole mess
1071 local $SIG{HUP} = 'IGNORE';
1072 local $SIG{INT} = 'IGNORE';
1073 local $SIG{QUIT} = 'IGNORE';
1074 local $SIG{TERM} = 'IGNORE';
1075 local $SIG{TSTP} = 'IGNORE';
1076 local $SIG{PIPE} = 'IGNORE';
1078 my $oldAutoCommit = $FS::UID::AutoCommit;
1079 local $FS::UID::AutoCommit = 0;
1083 my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1084 return "Customer not found: $custnum" unless $cust_main;
1086 my $change = scalar(@$remove_pkgnum) != 0;
1088 # Create the new packages.
1089 foreach my $pkgpart (@$pkgparts) {
1090 my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1091 pkgpart => $pkgpart };
1092 $error = $cust_pkg->insert( 'change' => $change );
1094 $dbh->rollback if $oldAutoCommit;
1097 push @$return_cust_pkg, $cust_pkg;
1099 # $return_cust_pkg now contains refs to all of the newly
1102 # Transfer services and cancel old packages.
1103 foreach my $old_pkgnum (@$remove_pkgnum) {
1104 my $old_pkg = qsearchs ('cust_pkg', { pkgnum => $old_pkgnum });
1106 foreach my $new_pkg (@$return_cust_pkg) {
1107 $error = $old_pkg->transfer($new_pkg);
1108 if ($error and $error == 0) {
1109 # $old_pkg->transfer failed.
1110 $dbh->rollback if $oldAutoCommit;
1115 if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1116 warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1117 foreach my $new_pkg (@$return_cust_pkg) {
1118 $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1119 if ($error and $error == 0) {
1120 # $old_pkg->transfer failed.
1121 $dbh->rollback if $oldAutoCommit;
1128 # Transfers were successful, but we went through all of the
1129 # new packages and still had services left on the old package.
1130 # We can't cancel the package under the circumstances, so abort.
1131 $dbh->rollback if $oldAutoCommit;
1132 return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1134 $error = $old_pkg->cancel;
1140 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1148 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
1150 In sub order, the @pkgparts array (passed by reference) is clobbered.
1152 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
1153 method to pass dates to the recur_prog expression, it should do so.
1155 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1156 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1157 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1158 configuration values. Probably need a subroutine which decides what to do
1159 based on whether or not we've fetched the user yet, rather than a hash. See
1160 FS::UID and the TODO.
1162 Now that things are transactional should the check in the insert method be
1167 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1168 L<FS::pkg_svc>, schema.html from the base documentation