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