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 custnum: ". $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('') if $self->manual_flag eq ' ';
 248     $self->manual_flag =~ /^([01]?)$/
 249       or return "Illegal manual_flag ". $self->manual_flag;
 250     $self->manual_flag($1);
 251   }
 252
 253   $self->SUPER::check;
 254 }
 255
 256 =item cancel [ OPTION => VALUE ... ]
 257
 258 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 259 in this package, then cancels the package itself (sets the cancel field to
 260 now).
 261
 262 Available options are: I<quiet>
 263
 264 I<quiet> can be set true to supress email cancellation notices.
 265
 266 If there is an error, returns the error, otherwise returns false.
 267
 268 =cut
 269
 270 sub cancel {
 271   my( $self, %options ) = @_;
 272   my $error;
 273
 274   local $SIG{HUP} = 'IGNORE';
 275   local $SIG{INT} = 'IGNORE';
 276   local $SIG{QUIT} = 'IGNORE';
 277   local $SIG{TERM} = 'IGNORE';
 278   local $SIG{TSTP} = 'IGNORE';
 279   local $SIG{PIPE} = 'IGNORE';
 280
 281   my $oldAutoCommit = $FS::UID::AutoCommit;
 282   local $FS::UID::AutoCommit = 0;
 283   my $dbh = dbh;
 284
 285   foreach my $cust_svc (
 286     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 287   ) {
 288     my $error = $cust_svc->cancel;
 289
 290     if ( $error ) {
 291       $dbh->rollback if $oldAutoCommit;
 292       return "Error cancelling cust_svc: $error";
 293     }
 294
 295   }
 296
 297   unless ( $self->getfield('cancel') ) {
 298     my %hash = $self->hash;
 299     $hash{'cancel'} = time;
 300     my $new = new FS::cust_pkg ( \%hash );
 301     $error = $new->replace($self);
 302     if ( $error ) {
 303       $dbh->rollback if $oldAutoCommit;
 304       return $error;
 305     }
 306   }
 307
 308   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 309
 310   my $conf = new FS::Conf;
 311   my @invoicing_list = grep { $_ ne 'POST' } $self->cust_main->invoicing_list;
 312   if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
 313     my $conf = new FS::Conf;
 314     my $error = send_email(
 315       'from'    => $conf->config('invoice_from'),
 316       'to'      => \@invoicing_list,
 317       'subject' => $conf->config('cancelsubject'),
 318       'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 319     );
 320     #should this do something on errors?
 321   }
 322
 323   ''; #no errors
 324
 325 }
 326
 327 =item suspend
 328
 329 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 330 package, then suspends the package itself (sets the susp field to now).
 331
 332 If there is an error, returns the error, otherwise returns false.
 333
 334 =cut
 335
 336 sub suspend {
 337   my $self = shift;
 338   my $error ;
 339
 340   local $SIG{HUP} = 'IGNORE';
 341   local $SIG{INT} = 'IGNORE';
 342   local $SIG{QUIT} = 'IGNORE';
 343   local $SIG{TERM} = 'IGNORE';
 344   local $SIG{TSTP} = 'IGNORE';
 345   local $SIG{PIPE} = 'IGNORE';
 346
 347   my $oldAutoCommit = $FS::UID::AutoCommit;
 348   local $FS::UID::AutoCommit = 0;
 349   my $dbh = dbh;
 350
 351   foreach my $cust_svc (
 352     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 353   ) {
 354     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 355
 356     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 357       $dbh->rollback if $oldAutoCommit;
 358       return "Illegal svcdb value in part_svc!";
 359     };
 360     my $svcdb = $1;
 361     require "FS/$svcdb.pm";
 362
 363     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 364     if ($svc) {
 365       $error = $svc->suspend;
 366       if ( $error ) {
 367         $dbh->rollback if $oldAutoCommit;
 368         return $error;
 369       }
 370     }
 371
 372   }
 373
 374   unless ( $self->getfield('susp') ) {
 375     my %hash = $self->hash;
 376     $hash{'susp'} = time;
 377     my $new = new FS::cust_pkg ( \%hash );
 378     $error = $new->replace($self);
 379     if ( $error ) {
 380       $dbh->rollback if $oldAutoCommit;
 381       return $error;
 382     }
 383   }
 384
 385   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 386
 387   ''; #no errors
 388 }
 389
 390 =item unsuspend
 391
 392 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 393 package, then unsuspends the package itself (clears the susp field).
 394
 395 If there is an error, returns the error, otherwise returns false.
 396
 397 =cut
 398
 399 sub unsuspend {
 400   my $self = shift;
 401   my($error);
 402
 403   local $SIG{HUP} = 'IGNORE';
 404   local $SIG{INT} = 'IGNORE';
 405   local $SIG{QUIT} = 'IGNORE';
 406   local $SIG{TERM} = 'IGNORE';
 407   local $SIG{TSTP} = 'IGNORE';
 408   local $SIG{PIPE} = 'IGNORE';
 409
 410   my $oldAutoCommit = $FS::UID::AutoCommit;
 411   local $FS::UID::AutoCommit = 0;
 412   my $dbh = dbh;
 413
 414   foreach my $cust_svc (
 415     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
 416   ) {
 417     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 418
 419     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 420       $dbh->rollback if $oldAutoCommit;
 421       return "Illegal svcdb value in part_svc!";
 422     };
 423     my $svcdb = $1;
 424     require "FS/$svcdb.pm";
 425
 426     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 427     if ($svc) {
 428       $error = $svc->unsuspend;
 429       if ( $error ) {
 430         $dbh->rollback if $oldAutoCommit;
 431         return $error;
 432       }
 433     }
 434
 435   }
 436
 437   unless ( ! $self->getfield('susp') ) {
 438     my %hash = $self->hash;
 439     $hash{'susp'} = '';
 440     my $new = new FS::cust_pkg ( \%hash );
 441     $error = $new->replace($self);
 442     if ( $error ) {
 443       $dbh->rollback if $oldAutoCommit;
 444       return $error;
 445     }
 446   }
 447
 448   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 449
 450   ''; #no errors
 451 }
 452
 453 =item last_bill
 454
 455 Returns the last bill date, or if there is no last bill date, the setup date.
 456 Useful for billing metered services.
 457
 458 =cut
 459
 460 sub last_bill {
 461   my $self = shift;
 462   if ( $self->dbdef_table->column('last_bill') ) {
 463     return $self->setfield('last_bill', $_[0]) if @_;
 464     return $self->getfield('last_bill') if $self->getfield('last_bill');
 465   }
 466   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
 467                                                   'edate'  => $self->bill,  } );
 468   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
 469 }
 470
 471 =item part_pkg
 472
 473 Returns the definition for this billing item, as an FS::part_pkg object (see
 474 L<FS::part_pkg>).
 475
 476 =cut
 477
 478 sub part_pkg {
 479   my $self = shift;
 480   #exists( $self->{'_pkgpart'} )
 481   $self->{'_pkgpart'}
 482     ? $self->{'_pkgpart'}
 483     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 484 }
 485
 486 =item cust_svc
 487
 488 Returns the services for this package, as FS::cust_svc objects (see
 489 L<FS::cust_svc>)
 490
 491 =cut
 492
 493 sub cust_svc {
 494   my $self = shift;
 495   if ( $self->{'_svcnum'} ) {
 496     values %{ $self->{'_svcnum'}->cache };
 497   } else {
 498     qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } );
 499   }
 500 }
 501
 502 =item labels
 503
 504 Returns a list of lists, calling the label method for all services
 505 (see L<FS::cust_svc>) of this billing item.
 506
 507 =cut
 508
 509 sub labels {
 510   my $self = shift;
 511   map { [ $_->label ] } $self->cust_svc;
 512 }
 513
 514 =item cust_main
 515
 516 Returns the parent customer object (see L<FS::cust_main>).
 517
 518 =cut
 519
 520 sub cust_main {
 521   my $self = shift;
 522   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 523 }
 524
 525 =item seconds_since TIMESTAMP
 526
 527 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
 528 package have been online since TIMESTAMP, according to the session monitor.
 529
 530 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 531 L<Time::Local> and L<Date::Parse> for conversion functions.
 532
 533 =cut
 534
 535 sub seconds_since {
 536   my($self, $since) = @_;
 537   my $seconds = 0;
 538
 539   foreach my $cust_svc (
 540     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
 541   ) {
 542     $seconds += $cust_svc->seconds_since($since);
 543   }
 544
 545   $seconds;
 546
 547 }
 548
 549 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 550
 551 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
 552 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
 553 (exclusive).
 554
 555 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 556 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 557 functions.
 558
 559
 560 =cut
 561
 562 sub seconds_since_sqlradacct {
 563   my($self, $start, $end) = @_;
 564
 565   my $seconds = 0;
 566
 567   foreach my $cust_svc (
 568     grep {
 569       my $part_svc = $_->part_svc;
 570       $part_svc->svcdb eq 'svc_acct'
 571         && scalar($part_svc->part_export('sqlradius'));
 572     } $self->cust_svc
 573   ) {
 574     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
 575   }
 576
 577   $seconds;
 578
 579 }
 580
 581 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 582
 583 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
 584 in this package for sessions ending between TIMESTAMP_START (inclusive) and
 585 TIMESTAMP_END
 586 (exclusive).
 587
 588 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 589 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 590 functions.
 591
 592 =cut
 593
 594 sub attribute_since_sqlradacct {
 595   my($self, $start, $end, $attrib) = @_;
 596
 597   my $sum = 0;
 598
 599   foreach my $cust_svc (
 600     grep {
 601       my $part_svc = $_->part_svc;
 602       $part_svc->svcdb eq 'svc_acct'
 603         && scalar($part_svc->part_export('sqlradius'));
 604     } $self->cust_svc
 605   ) {
 606     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
 607   }
 608
 609   $sum;
 610
 611 }
 612
 613 =item transfer DEST_PKGNUM
 614
 615 Transfers as many services as possible from this package to another package.
 616 The destination package must already exist.  Services are moved only if
 617 the destination allows services with the correct I<svcnum> (not svcdb).
 618 Any services that can't be moved remain in the original package.
 619
 620 Returns an error, if there is one; otherwise, returns the number of services
 621 that couldn't be moved.
 622
 623 =cut
 624
 625 sub transfer {
 626   my ($self, $dest_pkgnum) = @_;
 627
 628   my $remaining = 0;
 629   my $dest;
 630   my %target;
 631   my $pkg_svc;
 632
 633   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
 634     $dest = $dest_pkgnum;
 635     $dest_pkgnum = $dest->pkgnum;
 636   } else {
 637     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
 638   }
 639
 640   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
 641
 642   foreach $pkg_svc (qsearch('pkg_svc', { pkgpart => $dest->pkgpart })) {
 643     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
 644   }
 645
 646   my $cust_svc;
 647
 648   foreach $cust_svc ($dest->cust_svc) {
 649     $target{$cust_svc->svcpart}--;
 650   }
 651
 652   foreach $cust_svc ($self->cust_svc) {
 653     if($target{$cust_svc->svcpart} > 0) {
 654       $target{$cust_svc->svcpart}--;
 655       my $new = new FS::cust_svc {
 656           svcnum  => $cust_svc->svcnum,
 657           svcpart => $cust_svc->svcpart,
 658           pkgnum  => $dest_pkgnum };
 659       my $error = $new->replace($cust_svc);
 660       return $error if $error;
 661     } else {
 662       $remaining++
 663     }
 664   }
 665   return $remaining;
 666 }
 667
 668 =item reexport
 669
 670 =cut
 671
 672 sub reexport {
 673   my $self = shift;
 674
 675   local $SIG{HUP} = 'IGNORE';
 676   local $SIG{INT} = 'IGNORE';
 677   local $SIG{QUIT} = 'IGNORE';
 678   local $SIG{TERM} = 'IGNORE';
 679   local $SIG{TSTP} = 'IGNORE';
 680   local $SIG{PIPE} = 'IGNORE';
 681
 682   my $oldAutoCommit = $FS::UID::AutoCommit;
 683   local $FS::UID::AutoCommit = 0;
 684   my $dbh = dbh;
 685
 686   foreach my $cust_svc ( $self->cust_svc ) {
 687     #false laziness w/svc_Common::insert
 688     my $svc_x = $cust_svc->svc_x;
 689     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
 690       my $error = $part_export->export_insert($svc_x);
 691       if ( $error ) {
 692         $dbh->rollback if $oldAutoCommit;
 693         return $error;
 694       }
 695     }
 696   }
 697
 698   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 699   '';
 700
 701 }
 702
 703 =back
 704
 705 =head1 SUBROUTINES
 706
 707 =over 4
 708
 709 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
 710
 711 CUSTNUM is a customer (see L<FS::cust_main>)
 712
 713 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
 714 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
 715 permitted.
 716
 717 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
 718 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
 719 new billing items.  An error is returned if this is not possible (see
 720 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
 721 parameter.
 722
 723 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
 724 newly-created cust_pkg objects.
 725
 726 =cut
 727
 728 sub order {
 729
 730   # Rewritten to make use of the transfer() method, and in general
 731   # to not suck so badly.
 732
 733   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
 734
 735   # Transactionize this whole mess
 736   my $oldAutoCommit = $FS::UID::AutoCommit;
 737   local $FS::UID::AutoCommit = 0;
 738   my $dbh = dbh;
 739
 740   my $error;
 741   my $cust_main = qsearchs('cust_main', { custnum => $custnum });
 742   return "Customer not found: $custnum" unless $cust_main;
 743
 744   # Create the new packages.
 745   my $cust_pkg;
 746   foreach (@$pkgparts) {
 747     $cust_pkg = new FS::cust_pkg { custnum => $custnum,
 748                                    pkgpart => $_ };
 749     $error = $cust_pkg->insert;
 750     if ($error) {
 751       $dbh->rollback if $oldAutoCommit;
 752       return $error;
 753     }
 754     push @$return_cust_pkg, $cust_pkg;
 755   }
 756   # $return_cust_pkg now contains refs to all of the newly
 757   # created packages.
 758
 759   # Transfer services and cancel old packages.
 760   foreach my $old_pkgnum (@$remove_pkgnum) {
 761     my $old_pkg = qsearchs ('cust_pkg', { pkgnum => $old_pkgnum });
 762     foreach my $new_pkg (@$return_cust_pkg) {
 763       $error = $old_pkg->transfer($new_pkg);
 764       if ($error and $error == 0) {
 765         # $old_pkg->transfer failed.
 766         $dbh->rollback if $oldAutoCommit;
 767         return $error;
 768       }
 769     }
 770     if ($error > 0) {
 771       # Transfers were successful, but we went through all of the
 772       # new packages and still had services left on the old package.
 773       # We can't cancel the package under the circumstances, so abort.
 774       $dbh->rollback if $oldAutoCommit;
 775       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
 776     }
 777     $error = $old_pkg->cancel;
 778     if ($error) {
 779       $dbh->rollback;
 780       return $error;
 781     }
 782   }
 783   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 784   '';
 785 }
 786
 787 =back
 788
 789 =head1 BUGS
 790
 791 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
 792
 793 In sub order, the @pkgparts array (passed by reference) is clobbered.
 794
 795 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
 796 method to pass dates to the recur_prog expression, it should do so.
 797
 798 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
 799 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
 800 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
 801 configuration values.  Probably need a subroutine which decides what to do
 802 based on whether or not we've fetched the user yet, rather than a hash.  See
 803 FS::UID and the TODO.
 804
 805 Now that things are transactional should the check in the insert method be
 806 moved to check ?
 807
 808 =head1 SEE ALSO
 809
 810 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
 811 L<FS::pkg_svc>, schema.html from the base documentation
 812
 813 =cut
 814
 815 1;
 816