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     map  { $_->[0] }
 515     sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
 516     map {
 517           my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
 518                                                'svcpart' => $_->svcpart     } );
 519           [ $_,
 520             $pkg_svc ? $pkg_svc->primary_svc : '',
 521             $pkg_svc ? $pkg_svc->quantity : 0,
 522           ];
 523         }
 524     qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } );
 525   #}
 526 }
 527
 528 =item labels
 529
 530 Returns a list of lists, calling the label method for all services
 531 (see L<FS::cust_svc>) of this billing item.
 532
 533 =cut
 534
 535 sub labels {
 536   my $self = shift;
 537   map { [ $_->label ] } $self->cust_svc;
 538 }
 539
 540 =item cust_main
 541
 542 Returns the parent customer object (see L<FS::cust_main>).
 543
 544 =cut
 545
 546 sub cust_main {
 547   my $self = shift;
 548   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 549 }
 550
 551 =item seconds_since TIMESTAMP
 552
 553 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
 554 package have been online since TIMESTAMP, according to the session monitor.
 555
 556 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 557 L<Time::Local> and L<Date::Parse> for conversion functions.
 558
 559 =cut
 560
 561 sub seconds_since {
 562   my($self, $since) = @_;
 563   my $seconds = 0;
 564
 565   foreach my $cust_svc (
 566     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
 567   ) {
 568     $seconds += $cust_svc->seconds_since($since);
 569   }
 570
 571   $seconds;
 572
 573 }
 574
 575 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 576
 577 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
 578 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
 579 (exclusive).
 580
 581 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 582 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 583 functions.
 584
 585
 586 =cut
 587
 588 sub seconds_since_sqlradacct {
 589   my($self, $start, $end) = @_;
 590
 591   my $seconds = 0;
 592
 593   foreach my $cust_svc (
 594     grep {
 595       my $part_svc = $_->part_svc;
 596       $part_svc->svcdb eq 'svc_acct'
 597         && scalar($part_svc->part_export('sqlradius'));
 598     } $self->cust_svc
 599   ) {
 600     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
 601   }
 602
 603   $seconds;
 604
 605 }
 606
 607 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 608
 609 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
 610 in this package for sessions ending between TIMESTAMP_START (inclusive) and
 611 TIMESTAMP_END
 612 (exclusive).
 613
 614 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 615 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 616 functions.
 617
 618 =cut
 619
 620 sub attribute_since_sqlradacct {
 621   my($self, $start, $end, $attrib) = @_;
 622
 623   my $sum = 0;
 624
 625   foreach my $cust_svc (
 626     grep {
 627       my $part_svc = $_->part_svc;
 628       $part_svc->svcdb eq 'svc_acct'
 629         && scalar($part_svc->part_export('sqlradius'));
 630     } $self->cust_svc
 631   ) {
 632     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
 633   }
 634
 635   $sum;
 636
 637 }
 638
 639 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
 640
 641 Transfers as many services as possible from this package to another package.
 642
 643 The destination package can be specified by pkgnum by passing an FS::cust_pkg
 644 object.  The destination package must already exist.
 645
 646 Services are moved only if the destination allows services with the correct
 647 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
 648 this option with caution!  No provision is made for export differences
 649 between the old and new service definitions.  Probably only should be used
 650 when your exports for all service definitions of a given svcdb are identical.
 651 (attempt a transfer without it first, to move all possible svcpart-matching
 652 services)
 653
 654 Any services that can't be moved remain in the original package.
 655
 656 Returns an error, if there is one; otherwise, returns the number of services
 657 that couldn't be moved.
 658
 659 =cut
 660
 661 sub transfer {
 662   my ($self, $dest_pkgnum, %opt) = @_;
 663
 664   my $remaining = 0;
 665   my $dest;
 666   my %target;
 667
 668   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
 669     $dest = $dest_pkgnum;
 670     $dest_pkgnum = $dest->pkgnum;
 671   } else {
 672     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
 673   }
 674
 675   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
 676
 677   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
 678     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
 679   }
 680
 681   foreach my $cust_svc ($dest->cust_svc) {
 682     $target{$cust_svc->svcpart}--;
 683   }
 684
 685   my %svcpart2svcparts = ();
 686   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
 687     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
 688     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
 689       next if exists $svcpart2svcparts{$svcpart};
 690       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
 691       $svcpart2svcparts{$svcpart} = [
 692         map  { $_->[0] }
 693         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
 694         map {
 695               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
 696                                                    'svcpart' => $_          } );
 697               [ $_,
 698                 $pkg_svc ? $pkg_svc->primary_svc : '',
 699                 $pkg_svc ? $pkg_svc->quantity : 0,
 700               ];
 701             }
 702
 703         grep { $_ != $svcpart }
 704         map  { $_->svcpart }
 705         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
 706       ];
 707       warn "alternates for svcpart $svcpart: ".
 708            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
 709         if $DEBUG;
 710     }
 711   }
 712
 713   foreach my $cust_svc ($self->cust_svc) {
 714     if($target{$cust_svc->svcpart} > 0) {
 715       $target{$cust_svc->svcpart}--;
 716       my $new = new FS::cust_svc {
 717         svcnum  => $cust_svc->svcnum,
 718         svcpart => $cust_svc->svcpart,
 719         pkgnum  => $dest_pkgnum,
 720       };
 721       my $error = $new->replace($cust_svc);
 722       return $error if $error;
 723     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
 724       if ( $DEBUG ) {
 725         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
 726         warn "alternates to consider: ".
 727              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
 728       }
 729       my @alternate = grep {
 730                              warn "considering alternate svcpart $_: ".
 731                                   "$target{$_} available in new package\n"
 732                                if $DEBUG;
 733                              $target{$_} > 0;
 734                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
 735       if ( @alternate ) {
 736         warn "alternate(s) found\n" if $DEBUG;
 737         my $change_svcpart = $alternate[0];
 738         $target{$change_svcpart}--;
 739         my $new = new FS::cust_svc {
 740           svcnum  => $cust_svc->svcnum,
 741           svcpart => $change_svcpart,
 742           pkgnum  => $dest_pkgnum,
 743         };
 744         my $error = $new->replace($cust_svc);
 745         return $error if $error;
 746       } else {
 747         $remaining++;
 748       }
 749     } else {
 750       $remaining++
 751     }
 752   }
 753   return $remaining;
 754 }
 755
 756 =item reexport
 757
 758 This method is deprecated.  See the I<depend_jobnum> option to the insert and
 759 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
 760
 761 =cut
 762
 763 sub reexport {
 764   my $self = shift;
 765
 766   local $SIG{HUP} = 'IGNORE';
 767   local $SIG{INT} = 'IGNORE';
 768   local $SIG{QUIT} = 'IGNORE';
 769   local $SIG{TERM} = 'IGNORE';
 770   local $SIG{TSTP} = 'IGNORE';
 771   local $SIG{PIPE} = 'IGNORE';
 772
 773   my $oldAutoCommit = $FS::UID::AutoCommit;
 774   local $FS::UID::AutoCommit = 0;
 775   my $dbh = dbh;
 776
 777   foreach my $cust_svc ( $self->cust_svc ) {
 778     #false laziness w/svc_Common::insert
 779     my $svc_x = $cust_svc->svc_x;
 780     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
 781       my $error = $part_export->export_insert($svc_x);
 782       if ( $error ) {
 783         $dbh->rollback if $oldAutoCommit;
 784         return $error;
 785       }
 786     }
 787   }
 788
 789   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 790   '';
 791
 792 }
 793
 794 =back
 795
 796 =head1 SUBROUTINES
 797
 798 =over 4
 799
 800 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
 801
 802 CUSTNUM is a customer (see L<FS::cust_main>)
 803
 804 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
 805 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
 806 permitted.
 807
 808 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
 809 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
 810 new billing items.  An error is returned if this is not possible (see
 811 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
 812 parameter.
 813
 814 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
 815 newly-created cust_pkg objects.
 816
 817 =cut
 818
 819 sub order {
 820   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
 821
 822   my $conf = new FS::Conf;
 823
 824   # Transactionize this whole mess
 825   local $SIG{HUP} = 'IGNORE';
 826   local $SIG{INT} = 'IGNORE';
 827   local $SIG{QUIT} = 'IGNORE';
 828   local $SIG{TERM} = 'IGNORE';
 829   local $SIG{TSTP} = 'IGNORE';
 830   local $SIG{PIPE} = 'IGNORE';
 831
 832   my $oldAutoCommit = $FS::UID::AutoCommit;
 833   local $FS::UID::AutoCommit = 0;
 834   my $dbh = dbh;
 835
 836   my $error;
 837   my $cust_main = qsearchs('cust_main', { custnum => $custnum });
 838   return "Customer not found: $custnum" unless $cust_main;
 839
 840   # Create the new packages.
 841   my $cust_pkg;
 842   foreach (@$pkgparts) {
 843     $cust_pkg = new FS::cust_pkg { custnum => $custnum,
 844                                    pkgpart => $_ };
 845     $error = $cust_pkg->insert;
 846     if ($error) {
 847       $dbh->rollback if $oldAutoCommit;
 848       return $error;
 849     }
 850     push @$return_cust_pkg, $cust_pkg;
 851   }
 852   # $return_cust_pkg now contains refs to all of the newly
 853   # created packages.
 854
 855   # Transfer services and cancel old packages.
 856   foreach my $old_pkgnum (@$remove_pkgnum) {
 857     my $old_pkg = qsearchs ('cust_pkg', { pkgnum => $old_pkgnum });
 858
 859     foreach my $new_pkg (@$return_cust_pkg) {
 860       $error = $old_pkg->transfer($new_pkg);
 861       if ($error and $error == 0) {
 862         # $old_pkg->transfer failed.
 863         $dbh->rollback if $oldAutoCommit;
 864         return $error;
 865       }
 866     }
 867
 868     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
 869       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
 870       foreach my $new_pkg (@$return_cust_pkg) {
 871         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
 872         if ($error and $error == 0) {
 873           # $old_pkg->transfer failed.
 874         $dbh->rollback if $oldAutoCommit;
 875         return $error;
 876         }
 877       }
 878     }
 879
 880     if ($error > 0) {
 881       # Transfers were successful, but we went through all of the
 882       # new packages and still had services left on the old package.
 883       # We can't cancel the package under the circumstances, so abort.
 884       $dbh->rollback if $oldAutoCommit;
 885       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
 886     }
 887     $error = $old_pkg->cancel;
 888     if ($error) {
 889       $dbh->rollback;
 890       return $error;
 891     }
 892   }
 893   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 894   '';
 895 }
 896
 897 =back
 898
 899 =head1 BUGS
 900
 901 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
 902
 903 In sub order, the @pkgparts array (passed by reference) is clobbered.
 904
 905 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
 906 method to pass dates to the recur_prog expression, it should do so.
 907
 908 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
 909 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
 910 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
 911 configuration values.  Probably need a subroutine which decides what to do
 912 based on whether or not we've fetched the user yet, rather than a hash.  See
 913 FS::UID and the TODO.
 914
 915 Now that things are transactional should the check in the insert method be
 916 moved to check ?
 917
 918 =head1 SEE ALSO
 919
 920 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
 921 L<FS::pkg_svc>, schema.html from the base documentation
 922
 923 =cut
 924
 925 1;
 926