FS/FS/cust_pkg.pm

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