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