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_acct_sm;
  19 use FS::svc_domain;
  20 use FS::svc_www;
  21 use FS::svc_forward;
  22
  23 # need all this for sending cancel emails in sub cancel
  24
  25 use FS::Conf;
  26 use Date::Format;
  27 use Mail::Internet 1.44;
  28 use Mail::Header;
  29
  30 @ISA = qw( FS::Record );
  31
  32 $disable_agentcheck = 0;
  33
  34 sub _cache {
  35   my $self = shift;
  36   my ( $hashref, $cache ) = @_;
  37   #if ( $hashref->{'pkgpart'} ) {
  38   if ( $hashref->{'pkg'} ) {
  39     # #@{ $self->{'_pkgnum'} } = ();
  40     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  41     # $self->{'_pkgpart'} = $subcache;
  42     # #push @{ $self->{'_pkgnum'} },
  43     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  44     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  45   }
  46   if ( exists $hashref->{'svcnum'} ) {
  47     #@{ $self->{'_pkgnum'} } = ();
  48     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  49     $self->{'_svcnum'} = $subcache;
  50     #push @{ $self->{'_pkgnum'} },
  51     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  52   }
  53 }
  54
  55 =head1 NAME
  56
  57 FS::cust_pkg - Object methods for cust_pkg objects
  58
  59 =head1 SYNOPSIS
  60
  61   use FS::cust_pkg;
  62
  63   $record = new FS::cust_pkg \%hash;
  64   $record = new FS::cust_pkg { 'column' => 'value' };
  65
  66   $error = $record->insert;
  67
  68   $error = $new_record->replace($old_record);
  69
  70   $error = $record->delete;
  71
  72   $error = $record->check;
  73
  74   $error = $record->cancel;
  75
  76   $error = $record->suspend;
  77
  78   $error = $record->unsuspend;
  79
  80   $part_pkg = $record->part_pkg;
  81
  82   @labels = $record->labels;
  83
  84   $seconds = $record->seconds_since($timestamp);
  85
  86   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
  87   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
  88
  89 =head1 DESCRIPTION
  90
  91 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
  92 inherits from FS::Record.  The following fields are currently supported:
  93
  94 =over 4
  95
  96 =item pkgnum - primary key (assigned automatically for new billing items)
  97
  98 =item custnum - Customer (see L<FS::cust_main>)
  99
 100 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
 101
 102 =item setup - date
 103
 104 =item bill - date (next 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 customer ". $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   ''; #no error
 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
 314   if ( !$options{'quiet'} && $conf->exists('emailcancel')
 315        && grep { $_ ne 'POST' } $self->cust_main->invoicing_list) {
 316
 317       my @invoicing_list = $self->cust_main->invoicing_list;
 318
 319       my $invoice_from = $conf->config('invoice_from');
 320       my @print_text = map "$_\n", $conf->config('cancelmessage');
 321       my $subject = $conf->config('cancelsubject');
 322       my $smtpmachine = $conf->config('smtpmachine');
 323
 324       if ( grep { $_ ne 'POST' } @invoicing_list ) { #email invoice
 325           #false laziness w/FS::cust_pay::delete & fs_signup_server && ::realtime_card
 326           #$ENV{SMTPHOSTS} = $smtpmachine;
 327           $ENV{MAILADDRESS} = $invoice_from;
 328           my $header = new Mail::Header ( [
 329               "From: $invoice_from",
 330               "To: ". join(', ', grep { $_ ne 'POST' } @invoicing_list ),
 331               "Sender: $invoice_from",
 332               "Reply-To: $invoice_from",
 333               "Date: ". time2str("%a, %d %b %Y %X %z", time),
 334               "Subject: $subject",
 335                                      ] );
 336           my $message = new Mail::Internet (
 337               'Header' => $header,
 338               'Body' => [ @print_text ],
 339                                       );
 340           $!=0;
 341           $message->smtpsend( Host => $smtpmachine )
 342               or $message->smtpsend( Host => $smtpmachine, Debug => 1 );
 343           #should this return an error?
 344           }
 345   }
 346
 347   ''; #no errors
 348
 349 }
 350
 351 =item suspend
 352
 353 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 354 package, then suspends the package itself (sets the susp field to now).
 355
 356 If there is an error, returns the error, otherwise returns false.
 357
 358 =cut
 359
 360 sub suspend {
 361   my $self = shift;
 362   my $error ;
 363
 364   local $SIG{HUP} = 'IGNORE';
 365   local $SIG{INT} = 'IGNORE';
 366   local $SIG{QUIT} = 'IGNORE';
 367   local $SIG{TERM} = 'IGNORE';
 368   local $SIG{TSTP} = 'IGNORE';
 369   local $SIG{PIPE} = 'IGNORE';
 370
 371   my $oldAutoCommit = $FS::UID::AutoCommit;
 372   local $FS::UID::AutoCommit = 0;
 373   my $dbh = dbh;
 374
 375   foreach my $cust_svc (
 376     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 377   ) {
 378     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 379
 380     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 381       $dbh->rollback if $oldAutoCommit;
 382       return "Illegal svcdb value in part_svc!";
 383     };
 384     my $svcdb = $1;
 385     require "FS/$svcdb.pm";
 386
 387     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 388     if ($svc) {
 389       $error = $svc->suspend;
 390       if ( $error ) {
 391         $dbh->rollback if $oldAutoCommit;
 392         return $error;
 393       }
 394     }
 395
 396   }
 397
 398   unless ( $self->getfield('susp') ) {
 399     my %hash = $self->hash;
 400     $hash{'susp'} = time;
 401     my $new = new FS::cust_pkg ( \%hash );
 402     $error = $new->replace($self);
 403     if ( $error ) {
 404       $dbh->rollback if $oldAutoCommit;
 405       return $error;
 406     }
 407   }
 408
 409   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 410
 411   ''; #no errors
 412 }
 413
 414 =item unsuspend
 415
 416 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 417 package, then unsuspends the package itself (clears the susp field).
 418
 419 If there is an error, returns the error, otherwise returns false.
 420
 421 =cut
 422
 423 sub unsuspend {
 424   my $self = shift;
 425   my($error);
 426
 427   local $SIG{HUP} = 'IGNORE';
 428   local $SIG{INT} = 'IGNORE';
 429   local $SIG{QUIT} = 'IGNORE';
 430   local $SIG{TERM} = 'IGNORE';
 431   local $SIG{TSTP} = 'IGNORE';
 432   local $SIG{PIPE} = 'IGNORE';
 433
 434   my $oldAutoCommit = $FS::UID::AutoCommit;
 435   local $FS::UID::AutoCommit = 0;
 436   my $dbh = dbh;
 437
 438   foreach my $cust_svc (
 439     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
 440   ) {
 441     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 442
 443     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 444       $dbh->rollback if $oldAutoCommit;
 445       return "Illegal svcdb value in part_svc!";
 446     };
 447     my $svcdb = $1;
 448     require "FS/$svcdb.pm";
 449
 450     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 451     if ($svc) {
 452       $error = $svc->unsuspend;
 453       if ( $error ) {
 454         $dbh->rollback if $oldAutoCommit;
 455         return $error;
 456       }
 457     }
 458
 459   }
 460
 461   unless ( ! $self->getfield('susp') ) {
 462     my %hash = $self->hash;
 463     $hash{'susp'} = '';
 464     my $new = new FS::cust_pkg ( \%hash );
 465     $error = $new->replace($self);
 466     if ( $error ) {
 467       $dbh->rollback if $oldAutoCommit;
 468       return $error;
 469     }
 470   }
 471
 472   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 473
 474   ''; #no errors
 475 }
 476
 477 =item last_bill
 478
 479 Returns the last bill date, or if there is no last bill date, the setup date.
 480 Useful for billing metered services.
 481
 482 =cut
 483
 484 sub last_bill {
 485   my $self = shift;
 486   if ( $self->dbdef_table->column('manual_flag') ) {
 487     return $self->setfield('last_bill', $_[1]) if @_;
 488     return $self->getfield('last_bill') if $self->getfield('last_bill');
 489   }
 490   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
 491                                                   'edate'  => $self->bill,  } );
 492   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
 493 }
 494
 495 =item part_pkg
 496
 497 Returns the definition for this billing item, as an FS::part_pkg object (see
 498 L<FS::part_pkg>).
 499
 500 =cut
 501
 502 sub part_pkg {
 503   my $self = shift;
 504   #exists( $self->{'_pkgpart'} )
 505   $self->{'_pkgpart'}
 506     ? $self->{'_pkgpart'}
 507     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 508 }
 509
 510 =item cust_svc
 511
 512 Returns the services for this package, as FS::cust_svc objects (see
 513 L<FS::cust_svc>)
 514
 515 =cut
 516
 517 sub cust_svc {
 518   my $self = shift;
 519   if ( $self->{'_svcnum'} ) {
 520     values %{ $self->{'_svcnum'}->cache };
 521   } else {
 522     qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } );
 523   }
 524 }
 525
 526 =item labels
 527
 528 Returns a list of lists, calling the label method for all services
 529 (see L<FS::cust_svc>) of this billing item.
 530
 531 =cut
 532
 533 sub labels {
 534   my $self = shift;
 535   map { [ $_->label ] } $self->cust_svc;
 536 }
 537
 538 =item cust_main
 539
 540 Returns the parent customer object (see L<FS::cust_main>).
 541
 542 =cut
 543
 544 sub cust_main {
 545   my $self = shift;
 546   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 547 }
 548
 549 =item seconds_since TIMESTAMP
 550
 551 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
 552 package have been online since TIMESTAMP, according to the session monitor.
 553
 554 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 555 L<Time::Local> and L<Date::Parse> for conversion functions.
 556
 557 =cut
 558
 559 sub seconds_since {
 560   my($self, $since) = @_;
 561   my $seconds = 0;
 562
 563   foreach my $cust_svc (
 564     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
 565   ) {
 566     $seconds += $cust_svc->seconds_since($since);
 567   }
 568
 569   $seconds;
 570
 571 }
 572
 573 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 574
 575 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
 576 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
 577 (exclusive).
 578
 579 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 580 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 581 functions.
 582
 583
 584 =cut
 585
 586 sub seconds_since_sqlradacct {
 587   my($self, $start, $end) = @_;
 588
 589   my $seconds = 0;
 590
 591   foreach my $cust_svc (
 592     grep {
 593       my $part_svc = $_->part_svc;
 594       $part_svc->svcdb eq 'svc_acct'
 595         && scalar($part_svc->part_export('sqlradius'));
 596     } $self->cust_svc
 597   ) {
 598     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
 599   }
 600
 601   $seconds;
 602
 603 }
 604
 605 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 606
 607 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
 608 in this package for sessions ending between TIMESTAMP_START (inclusive) and
 609 TIMESTAMP_END (exclusive).
 610
 611 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 612 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 613 functions.
 614
 615 =cut
 616
 617 sub attribute_since_sqlradacct {
 618   my($self, $start, $end, $attrib) = @_;
 619
 620   my $sum = 0;
 621
 622   foreach my $cust_svc (
 623     grep {
 624       my $part_svc = $_->part_svc;
 625       $part_svc->svcdb eq 'svc_acct'
 626         && scalar($part_svc->part_export('sqlradius'));
 627     } $self->cust_svc
 628   ) {
 629     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
 630   }
 631
 632   $sum;
 633
 634 }
 635
 636 =item reexport
 637
 638 =cut
 639
 640 sub reexport {
 641   my $self = shift;
 642
 643   local $SIG{HUP} = 'IGNORE';
 644   local $SIG{INT} = 'IGNORE';
 645   local $SIG{QUIT} = 'IGNORE';
 646   local $SIG{TERM} = 'IGNORE';
 647   local $SIG{TSTP} = 'IGNORE';
 648   local $SIG{PIPE} = 'IGNORE';
 649
 650   my $oldAutoCommit = $FS::UID::AutoCommit;
 651   local $FS::UID::AutoCommit = 0;
 652   my $dbh = dbh;
 653
 654   foreach my $cust_svc ( $self->cust_svc ) {
 655     #false laziness w/svc_Common::insert
 656     my $svc_x = $cust_svc->svc_x;
 657     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
 658       my $error = $part_export->export_insert($svc_x);
 659       if ( $error ) {
 660         $dbh->rollback if $oldAutoCommit;
 661         return $error;
 662       }
 663     }
 664   }
 665
 666   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 667   '';
 668
 669 }
 670
 671 =back
 672
 673 =head1 SUBROUTINES
 674
 675 =over 4
 676
 677 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
 678
 679 CUSTNUM is a customer (see L<FS::cust_main>)
 680
 681 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
 682 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
 683 permitted.
 684
 685 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
 686 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
 687 new billing items.  An error is returned if this is not possible (see
 688 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
 689 parameter.
 690
 691 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
 692 newly-created cust_pkg objects.
 693
 694 =cut
 695
 696 sub order {
 697   my($custnum, $pkgparts, $remove_pkgnums, $return_cust_pkg) = @_;
 698   $remove_pkgnums = [] unless defined($remove_pkgnums);
 699
 700   my $oldAutoCommit = $FS::UID::AutoCommit;
 701   local $FS::UID::AutoCommit = 0;
 702   my $dbh = dbh;
 703
 704   # generate %part_pkg
 705   # $part_pkg{$pkgpart} is true iff $custnum may purchase $pkgpart
 706   #
 707   my($cust_main)=qsearchs('cust_main',{'custnum'=>$custnum});
 708   my($agent)=qsearchs('agent',{'agentnum'=> $cust_main->agentnum });
 709   my %part_pkg = %{ $agent->pkgpart_hashref };
 710
 711   my(%svcnum);
 712   # generate %svcnum
 713   # for those packages being removed:
 714   #@{ $svcnum{$svcpart} } goes from a svcpart to a list of FS::cust_svc objects
 715   my($pkgnum);
 716   foreach $pkgnum ( @{$remove_pkgnums} ) {
 717     foreach my $cust_svc (qsearch('cust_svc',{'pkgnum'=>$pkgnum})) {
 718       push @{ $svcnum{$cust_svc->getfield('svcpart')} }, $cust_svc;
 719     }
 720   }
 721
 722   my @cust_svc;
 723   #generate @cust_svc
 724   # for those packages the customer is purchasing:
 725   # @{$pkgparts} is a list of said packages, by pkgpart
 726   # @cust_svc is a corresponding list of lists of FS::Record objects
 727   foreach my $pkgpart ( @{$pkgparts} ) {
 728     unless ( $part_pkg{$pkgpart} ) {
 729       $dbh->rollback if $oldAutoCommit;
 730       return "Customer not permitted to purchase pkgpart $pkgpart!";
 731     }
 732     push @cust_svc, [
 733       map {
 734         ( $svcnum{$_} && @{ $svcnum{$_} } ) ? shift @{ $svcnum{$_} } : ();
 735       } map { $_->svcpart }
 736           qsearch('pkg_svc', { pkgpart  => $pkgpart,
 737                                quantity => { op=>'>', value=>'0', } } )
 738     ];
 739   }
 740
 741   #special-case until this can be handled better
 742   # move services to new svcparts - even if the svcparts don't match (svcdb
 743   # needs to...)
 744   # looks like they're moved in no particular order, ewwwwwwww
 745   # and looks like just one of each svcpart can be moved... o well
 746
 747   #start with still-leftover services
 748   #foreach my $svcpart ( grep { scalar(@{ $svcnum{$_} }) } keys %svcnum ) {
 749   foreach my $svcpart ( keys %svcnum ) {
 750     next unless @{ $svcnum{$svcpart} };
 751
 752     my $svcdb = $svcnum{$svcpart}->[0]->part_svc->svcdb;
 753
 754     #find an empty place to put one
 755     my $i = 0;
 756     foreach my $pkgpart ( @{$pkgparts} ) {
 757       my @pkg_svc =
 758         qsearch('pkg_svc', { pkgpart  => $pkgpart,
 759                              quantity => { op=>'>', value=>'0', } } );
 760       #my @pkg_svc =
 761       #  grep { $_->quantity > 0 } qsearch('pkg_svc', { pkgpart=>$pkgpart } );
 762       if ( ! @{$cust_svc[$i]} #find an empty place to put them with
 763            && grep { $svcdb eq $_->part_svc->svcdb } #with appropriate svcdb
 764                 @pkg_svc
 765       ) {
 766         my $new_svcpart =
 767           ( grep { $svcdb eq $_->part_svc->svcdb } @pkg_svc )[0]->svcpart;
 768         my $cust_svc = shift @{$svcnum{$svcpart}};
 769         $cust_svc->svcpart($new_svcpart);
 770         #warn "changing from $svcpart to $new_svcpart!!!\n";
 771         $cust_svc[$i] = [ $cust_svc ];
 772       }
 773       $i++;
 774     }
 775
 776   }
 777
 778   #check for leftover services
 779   foreach (keys %svcnum) {
 780     next unless @{ $svcnum{$_} };
 781     $dbh->rollback if $oldAutoCommit;
 782     return "Leftover services, svcpart $_: svcnum ".
 783            join(', ', map { $_->svcnum } @{ $svcnum{$_} } );
 784   }
 785
 786   #no leftover services, let's make changes.
 787
 788   local $SIG{HUP} = 'IGNORE';
 789   local $SIG{INT} = 'IGNORE';
 790   local $SIG{QUIT} = 'IGNORE';
 791   local $SIG{TERM} = 'IGNORE';
 792   local $SIG{TSTP} = 'IGNORE';
 793   local $SIG{PIPE} = 'IGNORE';
 794
 795   #first cancel old packages
 796   foreach my $pkgnum ( @{$remove_pkgnums} ) {
 797     my($old) = qsearchs('cust_pkg',{'pkgnum'=>$pkgnum});
 798     unless ( $old ) {
 799       $dbh->rollback if $oldAutoCommit;
 800       return "Package $pkgnum not found to remove!";
 801     }
 802     my(%hash) = $old->hash;
 803     $hash{'cancel'}=time;
 804     my($new) = new FS::cust_pkg ( \%hash );
 805     my($error)=$new->replace($old);
 806     if ( $error ) {
 807       $dbh->rollback if $oldAutoCommit;
 808       return "Couldn't update package $pkgnum: $error";
 809     }
 810   }
 811
 812   #now add new packages, changing cust_svc records if necessary
 813   my $pkgpart;
 814   while ($pkgpart=shift @{$pkgparts} ) {
 815
 816     my $new = new FS::cust_pkg {
 817                                  'custnum' => $custnum,
 818                                  'pkgpart' => $pkgpart,
 819                                };
 820     my $error = $new->insert;
 821     if ( $error ) {
 822       $dbh->rollback if $oldAutoCommit;
 823       return "Couldn't insert new cust_pkg record: $error";
 824     }
 825     push @{$return_cust_pkg}, $new if $return_cust_pkg;
 826     my $pkgnum = $new->pkgnum;
 827
 828     foreach my $cust_svc ( @{ shift @cust_svc } ) {
 829       my(%hash) = $cust_svc->hash;
 830       $hash{'pkgnum'}=$pkgnum;
 831       my $new = new FS::cust_svc ( \%hash );
 832
 833       #avoid Record diffing missing changed svcpart field from above.
 834       my $old = qsearchs('cust_svc', { 'svcnum' => $cust_svc->svcnum } );
 835
 836       my $error = $new->replace($old);
 837       if ( $error ) {
 838         $dbh->rollback if $oldAutoCommit;
 839         return "Couldn't link old service to new package: $error";
 840       }
 841     }
 842   }
 843
 844   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 845
 846   ''; #no errors
 847 }
 848
 849 =back
 850
 851 =head1 BUGS
 852
 853 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
 854
 855 In sub order, the @pkgparts array (passed by reference) is clobbered.
 856
 857 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
 858 method to pass dates to the recur_prog expression, it should do so.
 859
 860 FS::svc_acct, FS::svc_acct_sm, and FS::svc_domain are loaded via 'use' at
 861 compile time, rather than via 'require' in sub { setup, suspend, unsuspend,
 862 cancel } because they use %FS::UID::callback to load configuration values.
 863 Probably need a subroutine which decides what to do based on whether or not
 864 we've fetched the user yet, rather than a hash.  See FS::UID and the TODO.
 865
 866 Now that things are transactional should the check in the insert method be
 867 moved to check ?
 868
 869 =head1 SEE ALSO
 870
 871 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
 872 L<FS::pkg_svc>, schema.html from the base documentation
 873
 874 =cut
 875
 876 1;
 877