FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2
   3 use strict;
   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 );
   8 use FS::cust_svc;
   9 use FS::part_pkg;
  10 use FS::cust_main;
  11 use FS::type_pkgs;
  12 use FS::pkg_svc;
  13 use FS::cust_bill_pkg;
  14
  15 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  16 # setup }
  17 # because they load configuraion by setting FS::UID::callback (see TODO)
  18 use FS::svc_acct;
  19 use FS::svc_domain;
  20 use FS::svc_www;
  21 use FS::svc_forward;
  22
  23 # for sending cancel emails in sub cancel
  24 use FS::Conf;
  25
  26 @ISA = qw( FS::Record );
  27
  28 $DEBUG = 0;
  29
  30 $disable_agentcheck = 0;
  31
  32 # The order in which to unprovision services.
  33 @SVCDB_CANCEL_SEQ = qw( svc_external
  34                         svc_www
  35                         svc_forward
  36                         svc_acct
  37                         svc_domain
  38                         svc_broadband );
  39
  40 sub _cache {
  41   my $self = shift;
  42   my ( $hashref, $cache ) = @_;
  43   #if ( $hashref->{'pkgpart'} ) {
  44   if ( $hashref->{'pkg'} ) {
  45     # #@{ $self->{'_pkgnum'} } = ();
  46     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  47     # $self->{'_pkgpart'} = $subcache;
  48     # #push @{ $self->{'_pkgnum'} },
  49     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  50     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  51   }
  52   if ( exists $hashref->{'svcnum'} ) {
  53     #@{ $self->{'_pkgnum'} } = ();
  54     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  55     $self->{'_svcnum'} = $subcache;
  56     #push @{ $self->{'_pkgnum'} },
  57     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  58   }
  59 }
  60
  61 =head1 NAME
  62
  63 FS::cust_pkg - Object methods for cust_pkg objects
  64
  65 =head1 SYNOPSIS
  66
  67   use FS::cust_pkg;
  68
  69   $record = new FS::cust_pkg \%hash;
  70   $record = new FS::cust_pkg { 'column' => 'value' };
  71
  72   $error = $record->insert;
  73
  74   $error = $new_record->replace($old_record);
  75
  76   $error = $record->delete;
  77
  78   $error = $record->check;
  79
  80   $error = $record->cancel;
  81
  82   $error = $record->suspend;
  83
  84   $error = $record->unsuspend;
  85
  86   $part_pkg = $record->part_pkg;
  87
  88   @labels = $record->labels;
  89
  90   $seconds = $record->seconds_since($timestamp);
  91
  92   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
  93   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
  94
  95 =head1 DESCRIPTION
  96
  97 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
  98 inherits from FS::Record.  The following fields are currently supported:
  99
 100 =over 4
 101
 102 =item pkgnum - primary key (assigned automatically for new billing items)
 103
 104 =item custnum - Customer (see L<FS::cust_main>)
 105
 106 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
 107
 108 =item setup - date
 109
 110 =item bill - date (next bill date)
 111
 112 =item last_bill - last bill date
 113
 114 =item susp - date
 115
 116 =item expire - date
 117
 118 =item cancel - date
 119
 120 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
 121
 122 =item manual_flag - If this field is set to 1, disables the automatic
 123 unsuspension of this package when using the B<unsuspendauto> config file.
 124
 125 =back
 126
 127 Note: setup, bill, susp, expire and cancel are specified as UNIX timestamps;
 128 see L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for
 129 conversion functions.
 130
 131 =head1 METHODS
 132
 133 =over 4
 134
 135 =item new HASHREF
 136
 137 Create a new billing item.  To add the item to the database, see L<"insert">.
 138
 139 =cut
 140
 141 sub table { 'cust_pkg'; }
 142
 143 =item insert
 144
 145 Adds this billing item to the database ("Orders" the item).  If there is an
 146 error, returns the error, otherwise returns false.
 147
 148 =cut
 149
 150 sub insert {
 151   my $self = shift;
 152
 153   # custnum might not have have been defined in sub check (for one-shot new
 154   # customers), so check it here instead
 155   # (is this still necessary with transactions?)
 156
 157   my $error = $self->ut_number('custnum');
 158   return $error if $error;
 159
 160   my $cust_main = $self->cust_main;
 161   return "Unknown custnum: ". $self->custnum unless $cust_main;
 162
 163   unless ( $disable_agentcheck ) {
 164     my $agent = qsearchs( 'agent', { 'agentnum' => $cust_main->agentnum } );
 165     my $pkgpart_href = $agent->pkgpart_hashref;
 166     return "agent ". $agent->agentnum.
 167            " can't purchase pkgpart ". $self->pkgpart
 168       unless $pkgpart_href->{ $self->pkgpart };
 169   }
 170
 171   $self->SUPER::insert;
 172
 173 }
 174
 175 =item delete
 176
 177 This method now works but you probably shouldn't use it.
 178
 179 You don't want to delete billing items, because there would then be no record
 180 the customer ever purchased the item.  Instead, see the cancel method.
 181
 182 =cut
 183
 184 #sub delete {
 185 #  return "Can't delete cust_pkg records!";
 186 #}
 187
 188 =item replace OLD_RECORD
 189
 190 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 191 returns the error, otherwise returns false.
 192
 193 Currently, custnum, setup, bill, susp, expire, and cancel may be changed.
 194
 195 Changing pkgpart may have disasterous effects.  See the order subroutine.
 196
 197 setup and bill are normally updated by calling the bill method of a customer
 198 object (see L<FS::cust_main>).
 199
 200 suspend is normally updated by the suspend and unsuspend methods.
 201
 202 cancel is normally updated by the cancel method (and also the order subroutine
 203 in some cases).
 204
 205 =cut
 206
 207 sub replace {
 208   my( $new, $old ) = ( shift, shift );
 209
 210   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 211   return "Can't change otaker!" if $old->otaker ne $new->otaker;
 212
 213   #allow this *sigh*
 214   #return "Can't change setup once it exists!"
 215   #  if $old->getfield('setup') &&
 216   #     $old->getfield('setup') != $new->getfield('setup');
 217
 218   #some logic for bill, susp, cancel?
 219
 220   $new->SUPER::replace($old);
 221 }
 222
 223 =item check
 224
 225 Checks all fields to make sure this is a valid billing item.  If there is an
 226 error, returns the error, otherwise returns false.  Called by the insert and
 227 replace methods.
 228
 229 =cut
 230
 231 sub check {
 232   my $self = shift;
 233
 234   my $error =
 235     $self->ut_numbern('pkgnum')
 236     || $self->ut_numbern('custnum')
 237     || $self->ut_number('pkgpart')
 238     || $self->ut_numbern('setup')
 239     || $self->ut_numbern('bill')
 240     || $self->ut_numbern('susp')
 241     || $self->ut_numbern('cancel')
 242   ;
 243   return $error if $error;
 244
 245   if ( $self->custnum ) {
 246     return "Unknown customer ". $self->custnum unless $self->cust_main;
 247   }
 248
 249   return "Unknown pkgpart: ". $self->pkgpart
 250     unless qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 251
 252   $self->otaker(getotaker) unless $self->otaker;
 253   $self->otaker =~ /^([\w\.\-]{0,16})$/ or return "Illegal otaker";
 254   $self->otaker($1);
 255
 256   if ( $self->dbdef_table->column('manual_flag') ) {
 257     $self->manual_flag('') if $self->manual_flag eq ' ';
 258     $self->manual_flag =~ /^([01]?)$/
 259       or return "Illegal manual_flag ". $self->manual_flag;
 260     $self->manual_flag($1);
 261   }
 262
 263   $self->SUPER::check;
 264 }
 265
 266 =item cancel [ OPTION => VALUE ... ]
 267
 268 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 269 in this package, then cancels the package itself (sets the cancel field to
 270 now).
 271
 272 Available options are: I<quiet>
 273
 274 I<quiet> can be set true to supress email cancellation notices.
 275
 276 If there is an error, returns the error, otherwise returns false.
 277
 278 =cut
 279
 280 sub cancel {
 281   my( $self, %options ) = @_;
 282   my $error;
 283
 284   local $SIG{HUP} = 'IGNORE';
 285   local $SIG{INT} = 'IGNORE';
 286   local $SIG{QUIT} = 'IGNORE';
 287   local $SIG{TERM} = 'IGNORE';
 288   local $SIG{TSTP} = 'IGNORE';
 289   local $SIG{PIPE} = 'IGNORE';
 290
 291   my $oldAutoCommit = $FS::UID::AutoCommit;
 292   local $FS::UID::AutoCommit = 0;
 293   my $dbh = dbh;
 294
 295   my %svc;
 296   foreach my $cust_svc (
 297       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 298   ) {
 299     push @{ $svc{$cust_svc->part_svc->svcdb} }, $cust_svc;
 300   }
 301
 302   foreach my $svcdb (@SVCDB_CANCEL_SEQ) {
 303     foreach my $cust_svc (@{ $svc{$svcdb} }) {
 304       my $error = $cust_svc->cancel;
 305
 306       if ( $error ) {
 307         $dbh->rollback if $oldAutoCommit;
 308         return "Error cancelling cust_svc: $error";
 309       }
 310     }
 311   }
 312
 313   unless ( $self->getfield('cancel') ) {
 314     my %hash = $self->hash;
 315     $hash{'cancel'} = time;
 316     my $new = new FS::cust_pkg ( \%hash );
 317     $error = $new->replace($self);
 318     if ( $error ) {
 319       $dbh->rollback if $oldAutoCommit;
 320       return $error;
 321     }
 322   }
 323
 324   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 325
 326   my $conf = new FS::Conf;
 327   my @invoicing_list = grep { $_ ne 'POST' } $self->cust_main->invoicing_list;
 328   if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
 329     my $conf = new FS::Conf;
 330     my $error = send_email(
 331       'from'    => $conf->config('invoice_from'),
 332       'to'      => \@invoicing_list,
 333       'subject' => $conf->config('cancelsubject'),
 334       'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 335     );
 336     #should this do something on errors?
 337   }
 338
 339   ''; #no errors
 340
 341 }
 342
 343 =item suspend
 344
 345 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 346 package, then suspends the package itself (sets the susp field to now).
 347
 348 If there is an error, returns the error, otherwise returns false.
 349
 350 =cut
 351
 352 sub suspend {
 353   my $self = shift;
 354   my $error ;
 355
 356   local $SIG{HUP} = 'IGNORE';
 357   local $SIG{INT} = 'IGNORE';
 358   local $SIG{QUIT} = 'IGNORE';
 359   local $SIG{TERM} = 'IGNORE';
 360   local $SIG{TSTP} = 'IGNORE';
 361   local $SIG{PIPE} = 'IGNORE';
 362
 363   my $oldAutoCommit = $FS::UID::AutoCommit;
 364   local $FS::UID::AutoCommit = 0;
 365   my $dbh = dbh;
 366
 367   foreach my $cust_svc (
 368     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 369   ) {
 370     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 371
 372     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 373       $dbh->rollback if $oldAutoCommit;
 374       return "Illegal svcdb value in part_svc!";
 375     };
 376     my $svcdb = $1;
 377     require "FS/$svcdb.pm";
 378
 379     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 380     if ($svc) {
 381       $error = $svc->suspend;
 382       if ( $error ) {
 383         $dbh->rollback if $oldAutoCommit;
 384         return $error;
 385       }
 386     }
 387
 388   }
 389
 390   unless ( $self->getfield('susp') ) {
 391     my %hash = $self->hash;
 392     $hash{'susp'} = time;
 393     my $new = new FS::cust_pkg ( \%hash );
 394     $error = $new->replace($self);
 395     if ( $error ) {
 396       $dbh->rollback if $oldAutoCommit;
 397       return $error;
 398     }
 399   }
 400
 401   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 402
 403   ''; #no errors
 404 }
 405
 406 =item unsuspend
 407
 408 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 409 package, then unsuspends the package itself (clears the susp field).
 410
 411 If there is an error, returns the error, otherwise returns false.
 412
 413 =cut
 414
 415 sub unsuspend {
 416   my $self = shift;
 417   my($error);
 418
 419   local $SIG{HUP} = 'IGNORE';
 420   local $SIG{INT} = 'IGNORE';
 421   local $SIG{QUIT} = 'IGNORE';
 422   local $SIG{TERM} = 'IGNORE';
 423   local $SIG{TSTP} = 'IGNORE';
 424   local $SIG{PIPE} = 'IGNORE';
 425
 426   my $oldAutoCommit = $FS::UID::AutoCommit;
 427   local $FS::UID::AutoCommit = 0;
 428   my $dbh = dbh;
 429
 430   foreach my $cust_svc (
 431     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
 432   ) {
 433     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 434
 435     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 436       $dbh->rollback if $oldAutoCommit;
 437       return "Illegal svcdb value in part_svc!";
 438     };
 439     my $svcdb = $1;
 440     require "FS/$svcdb.pm";
 441
 442     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 443     if ($svc) {
 444       $error = $svc->unsuspend;
 445       if ( $error ) {
 446         $dbh->rollback if $oldAutoCommit;
 447         return $error;
 448       }
 449     }
 450
 451   }
 452
 453   unless ( ! $self->getfield('susp') ) {
 454     my %hash = $self->hash;
 455     $hash{'susp'} = '';
 456     my $new = new FS::cust_pkg ( \%hash );
 457     $error = $new->replace($self);
 458     if ( $error ) {
 459       $dbh->rollback if $oldAutoCommit;
 460       return $error;
 461     }
 462   }
 463
 464   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 465
 466   ''; #no errors
 467 }
 468
 469 =item last_bill
 470
 471 Returns the last bill date, or if there is no last bill date, the setup date.
 472 Useful for billing metered services.
 473
 474 =cut
 475
 476 sub last_bill {
 477   my $self = shift;
 478   if ( $self->dbdef_table->column('last_bill') ) {
 479     return $self->setfield('last_bill', $_[0]) if @_;
 480     return $self->getfield('last_bill') if $self->getfield('last_bill');
 481   }
 482   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
 483                                                   'edate'  => $self->bill,  } );
 484   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
 485 }
 486
 487 =item part_pkg
 488
 489 Returns the definition for this billing item, as an FS::part_pkg object (see
 490 L<FS::part_pkg>).
 491
 492 =cut
 493
 494 sub part_pkg {
 495   my $self = shift;
 496   #exists( $self->{'_pkgpart'} )
 497   $self->{'_pkgpart'}
 498     ? $self->{'_pkgpart'}
 499     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 500 }
 501
 502 =item cust_svc
 503
 504 Returns the services for this package, as FS::cust_svc objects (see
 505 L<FS::cust_svc>)
 506
 507 =cut
 508
 509 sub cust_svc {
 510   my $self = shift;
 511   if ( $self->{'_svcnum'} ) {
 512     values %{ $self->{'_svcnum'}->cache };
 513   } else {
 514     qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } );
 515   }
 516 }
 517
 518 =item labels
 519
 520 Returns a list of lists, calling the label method for all services
 521 (see L<FS::cust_svc>) of this billing item.
 522
 523 =cut
 524
 525 sub labels {
 526   my $self = shift;
 527   map { [ $_->label ] } $self->cust_svc;
 528 }
 529
 530 =item cust_main
 531
 532 Returns the parent customer object (see L<FS::cust_main>).
 533
 534 =cut
 535
 536 sub cust_main {
 537   my $self = shift;
 538   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 539 }
 540
 541 =item seconds_since TIMESTAMP
 542
 543 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
 544 package have been online since TIMESTAMP, according to the session monitor.
 545
 546 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 547 L<Time::Local> and L<Date::Parse> for conversion functions.
 548
 549 =cut
 550
 551 sub seconds_since {
 552   my($self, $since) = @_;
 553   my $seconds = 0;
 554
 555   foreach my $cust_svc (
 556     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
 557   ) {
 558     $seconds += $cust_svc->seconds_since($since);
 559   }
 560
 561   $seconds;
 562
 563 }
 564
 565 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 566
 567 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
 568 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
 569 (exclusive).
 570
 571 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 572 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 573 functions.
 574
 575
 576 =cut
 577
 578 sub seconds_since_sqlradacct {
 579   my($self, $start, $end) = @_;
 580
 581   my $seconds = 0;
 582
 583   foreach my $cust_svc (
 584     grep {
 585       my $part_svc = $_->part_svc;
 586       $part_svc->svcdb eq 'svc_acct'
 587         && scalar($part_svc->part_export('sqlradius'));
 588     } $self->cust_svc
 589   ) {
 590     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
 591   }
 592
 593   $seconds;
 594
 595 }
 596
 597 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 598
 599 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
 600 in this package for sessions ending between TIMESTAMP_START (inclusive) and
 601 TIMESTAMP_END
 602 (exclusive).
 603
 604 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 605 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 606 functions.
 607
 608 =cut
 609
 610 sub attribute_since_sqlradacct {
 611   my($self, $start, $end, $attrib) = @_;
 612
 613   my $sum = 0;
 614
 615   foreach my $cust_svc (
 616     grep {
 617       my $part_svc = $_->part_svc;
 618       $part_svc->svcdb eq 'svc_acct'
 619         && scalar($part_svc->part_export('sqlradius'));
 620     } $self->cust_svc
 621   ) {
 622     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
 623   }
 624
 625   $sum;
 626
 627 }
 628
 629 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
 630
 631 Transfers as many services as possible from this package to another package.
 632
 633 The destination package can be specified by pkgnum by passing an FS::cust_pkg
 634 object.  The destination package must already exist.
 635
 636 Services are moved only if the destination allows services with the correct
 637 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
 638 this option with caution!  No provision is made for export differences
 639 between the old and new service definitions.  Probably only should be used
 640 when your exports for all service definitions of a given svcdb are identical.
 641 (attempt a transfer without it first, to move all possible svcpart-matching
 642 services)
 643
 644 Any services that can't be moved remain in the original package.
 645
 646 Returns an error, if there is one; otherwise, returns the number of services
 647 that couldn't be moved.
 648
 649 =cut
 650
 651 sub transfer {
 652   my ($self, $dest_pkgnum, %opt) = @_;
 653
 654   my $remaining = 0;
 655   my $dest;
 656   my %target;
 657   my $pkg_svc;
 658
 659   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
 660     $dest = $dest_pkgnum;
 661     $dest_pkgnum = $dest->pkgnum;
 662   } else {
 663     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
 664   }
 665
 666   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
 667
 668   foreach $pkg_svc (qsearch('pkg_svc', { pkgpart => $dest->pkgpart })) {
 669     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
 670   }
 671
 672   my $cust_svc;
 673
 674   foreach $cust_svc ($dest->cust_svc) {
 675     $target{$cust_svc->svcpart}--;
 676   }
 677
 678   my %svcpart2svcparts = ();
 679   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
 680     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
 681     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
 682       next if exists $svcpart2svcparts{$svcpart};
 683       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
 684       $svcpart2svcparts{$svcpart} = [
 685         grep { $_ != $svcpart }
 686           map { $_->svcpart }
 687             qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
 688       ];
 689       warn "alternates for svcpart $svcpart: ".
 690            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
 691         if $DEBUG;
 692     }
 693   }
 694
 695   foreach $cust_svc ($self->cust_svc) {
 696     if($target{$cust_svc->svcpart} > 0) {
 697       $target{$cust_svc->svcpart}--;
 698       my $new = new FS::cust_svc {
 699         svcnum  => $cust_svc->svcnum,
 700         svcpart => $cust_svc->svcpart,
 701         pkgnum  => $dest_pkgnum,
 702       };
 703       my $error = $new->replace($cust_svc);
 704       return $error if $error;
 705     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
 706       if ( $DEBUG ) {
 707         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
 708         warn "alternates to consider: ".
 709              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
 710       }
 711       my @alternate = grep {
 712                              warn "considering alternate svcpart $_: ".
 713                                   "$target{$_} available in new package\n"
 714                                if $DEBUG;
 715                              $target{$_} > 0;
 716                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
 717       if ( @alternate ) {
 718         warn "alternate(s) found\n" if $DEBUG;
 719         my $change_svcpart = $alternate[0]; #arbitrary.
 720         $target{$change_svcpart}--;
 721         my $new = new FS::cust_svc {
 722           svcnum  => $cust_svc->svcnum,
 723           svcpart => $change_svcpart,
 724           pkgnum  => $dest_pkgnum,
 725         };
 726         my $error = $new->replace($cust_svc);
 727         return $error if $error;
 728       } else {
 729         $remaining++;
 730       }
 731     } else {
 732       $remaining++
 733     }
 734   }
 735   return $remaining;
 736 }
 737
 738 =item reexport
 739
 740 This method is deprecated.  See the I<depend_jobnum> option to the insert and
 741 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
 742
 743 =cut
 744
 745 sub reexport {
 746   my $self = shift;
 747
 748   local $SIG{HUP} = 'IGNORE';
 749   local $SIG{INT} = 'IGNORE';
 750   local $SIG{QUIT} = 'IGNORE';
 751   local $SIG{TERM} = 'IGNORE';
 752   local $SIG{TSTP} = 'IGNORE';
 753   local $SIG{PIPE} = 'IGNORE';
 754
 755   my $oldAutoCommit = $FS::UID::AutoCommit;
 756   local $FS::UID::AutoCommit = 0;
 757   my $dbh = dbh;
 758
 759   foreach my $cust_svc ( $self->cust_svc ) {
 760     #false laziness w/svc_Common::insert
 761     my $svc_x = $cust_svc->svc_x;
 762     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
 763       my $error = $part_export->export_insert($svc_x);
 764       if ( $error ) {
 765         $dbh->rollback if $oldAutoCommit;
 766         return $error;
 767       }
 768     }
 769   }
 770
 771   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 772   '';
 773
 774 }
 775
 776 =back
 777
 778 =head1 SUBROUTINES
 779
 780 =over 4
 781
 782 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
 783
 784 CUSTNUM is a customer (see L<FS::cust_main>)
 785
 786 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
 787 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
 788 permitted.
 789
 790 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
 791 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
 792 new billing items.  An error is returned if this is not possible (see
 793 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
 794 parameter.
 795
 796 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
 797 newly-created cust_pkg objects.
 798
 799 =cut
 800
 801 sub order {
 802   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
 803
 804   my $conf = new FS::Conf;
 805
 806   # Transactionize this whole mess
 807   local $SIG{HUP} = 'IGNORE';
 808   local $SIG{INT} = 'IGNORE';
 809   local $SIG{QUIT} = 'IGNORE';
 810   local $SIG{TERM} = 'IGNORE';
 811   local $SIG{TSTP} = 'IGNORE';
 812   local $SIG{PIPE} = 'IGNORE';
 813
 814   my $oldAutoCommit = $FS::UID::AutoCommit;
 815   local $FS::UID::AutoCommit = 0;
 816   my $dbh = dbh;
 817
 818   my $error;
 819   my $cust_main = qsearchs('cust_main', { custnum => $custnum });
 820   return "Customer not found: $custnum" unless $cust_main;
 821
 822   # Create the new packages.
 823   my $cust_pkg;
 824   foreach (@$pkgparts) {
 825     $cust_pkg = new FS::cust_pkg { custnum => $custnum,
 826                                    pkgpart => $_ };
 827     $error = $cust_pkg->insert;
 828     if ($error) {
 829       $dbh->rollback if $oldAutoCommit;
 830       return $error;
 831     }
 832     push @$return_cust_pkg, $cust_pkg;
 833   }
 834   # $return_cust_pkg now contains refs to all of the newly
 835   # created packages.
 836
 837   # Transfer services and cancel old packages.
 838   foreach my $old_pkgnum (@$remove_pkgnum) {
 839     my $old_pkg = qsearchs ('cust_pkg', { pkgnum => $old_pkgnum });
 840
 841     foreach my $new_pkg (@$return_cust_pkg) {
 842       $error = $old_pkg->transfer($new_pkg);
 843       if ($error and $error == 0) {
 844         # $old_pkg->transfer failed.
 845         $dbh->rollback if $oldAutoCommit;
 846         return $error;
 847       }
 848     }
 849
 850     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
 851       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
 852       foreach my $new_pkg (@$return_cust_pkg) {
 853         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
 854         if ($error and $error == 0) {
 855           # $old_pkg->transfer failed.
 856         $dbh->rollback if $oldAutoCommit;
 857         return $error;
 858         }
 859       }
 860     }
 861
 862     if ($error > 0) {
 863       # Transfers were successful, but we went through all of the
 864       # new packages and still had services left on the old package.
 865       # We can't cancel the package under the circumstances, so abort.
 866       $dbh->rollback if $oldAutoCommit;
 867       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
 868     }
 869     $error = $old_pkg->cancel;
 870     if ($error) {
 871       $dbh->rollback;
 872       return $error;
 873     }
 874   }
 875   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 876   '';
 877 }
 878
 879 =back
 880
 881 =head1 BUGS
 882
 883 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
 884
 885 In sub order, the @pkgparts array (passed by reference) is clobbered.
 886
 887 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
 888 method to pass dates to the recur_prog expression, it should do so.
 889
 890 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
 891 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
 892 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
 893 configuration values.  Probably need a subroutine which decides what to do
 894 based on whether or not we've fetched the user yet, rather than a hash.  See
 895 FS::UID and the TODO.
 896
 897 Now that things are transactional should the check in the insert method be
 898 moved to check ?
 899
 900 =head1 SEE ALSO
 901
 902 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
 903 L<FS::pkg_svc>, schema.html from the base documentation
 904
 905 =cut
 906
 907 1;
 908