FS/FS/cust_pkg.pm

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