FS/FS/cust_pkg.pm

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