FS/FS/cust_pkg.pm

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