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