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