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 This method is deprecated.  See the I<depend_jobnum> option to the insert and
 641 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
 642
 643 =cut
 644
 645 sub reexport {
 646   my $self = shift;
 647
 648   local $SIG{HUP} = 'IGNORE';
 649   local $SIG{INT} = 'IGNORE';
 650   local $SIG{QUIT} = 'IGNORE';
 651   local $SIG{TERM} = 'IGNORE';
 652   local $SIG{TSTP} = 'IGNORE';
 653   local $SIG{PIPE} = 'IGNORE';
 654
 655   my $oldAutoCommit = $FS::UID::AutoCommit;
 656   local $FS::UID::AutoCommit = 0;
 657   my $dbh = dbh;
 658
 659   foreach my $cust_svc ( $self->cust_svc ) {
 660     #false laziness w/svc_Common::insert
 661     my $svc_x = $cust_svc->svc_x;
 662     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
 663       my $error = $part_export->export_insert($svc_x);
 664       if ( $error ) {
 665         $dbh->rollback if $oldAutoCommit;
 666         return $error;
 667       }
 668     }
 669   }
 670
 671   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 672   '';
 673
 674 }
 675
 676 =back
 677
 678 =head1 SUBROUTINES
 679
 680 =over 4
 681
 682 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
 683
 684 CUSTNUM is a customer (see L<FS::cust_main>)
 685
 686 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
 687 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
 688 permitted.
 689
 690 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
 691 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
 692 new billing items.  An error is returned if this is not possible (see
 693 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
 694 parameter.
 695
 696 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
 697 newly-created cust_pkg objects.
 698
 699 =cut
 700
 701 sub order {
 702   my($custnum, $pkgparts, $remove_pkgnums, $return_cust_pkg) = @_;
 703   $remove_pkgnums = [] unless defined($remove_pkgnums);
 704
 705   my $oldAutoCommit = $FS::UID::AutoCommit;
 706   local $FS::UID::AutoCommit = 0;
 707   my $dbh = dbh;
 708
 709   # generate %part_pkg
 710   # $part_pkg{$pkgpart} is true iff $custnum may purchase $pkgpart
 711   #
 712   my($cust_main)=qsearchs('cust_main',{'custnum'=>$custnum});
 713   my($agent)=qsearchs('agent',{'agentnum'=> $cust_main->agentnum });
 714   my %part_pkg = %{ $agent->pkgpart_hashref };
 715
 716   my(%svcnum);
 717   # generate %svcnum
 718   # for those packages being removed:
 719   #@{ $svcnum{$svcpart} } goes from a svcpart to a list of FS::cust_svc objects
 720   my($pkgnum);
 721   foreach $pkgnum ( @{$remove_pkgnums} ) {
 722     foreach my $cust_svc (qsearch('cust_svc',{'pkgnum'=>$pkgnum})) {
 723       push @{ $svcnum{$cust_svc->getfield('svcpart')} }, $cust_svc;
 724     }
 725   }
 726   if ( $DEBUG ) {
 727     foreach my $svcpart ( keys %svcnum ) {
 728       warn "initial svcpart $svcpart: existing svcnums ".
 729            join(', ', map { $_->svcnum } @{$svcnum{$svcpart}} ). "\n";
 730     }
 731   }
 732
 733   my @cust_svc;
 734   #generate @cust_svc
 735   # for those packages the customer is purchasing:
 736   # @{$pkgparts} is a list of said packages, by pkgpart
 737   # @cust_svc is a corresponding list of lists of FS::Record objects
 738   foreach my $pkgpart ( @{$pkgparts} ) {
 739     unless ( $part_pkg{$pkgpart} ) {
 740       $dbh->rollback if $oldAutoCommit;
 741       return "Customer not permitted to purchase pkgpart $pkgpart!";
 742     }
 743     push @cust_svc, [
 744       map {
 745         my $svcnum = $svcnum{$_->{svcpart}};
 746         if ( $svcnum && @$svcnum ) {
 747           my $num = ( $_->{quantity} < scalar(@$svcnum) )
 748                       ? $_->{quantity}
 749                       : scalar(@$svcnum);
 750           splice @$svcnum, 0, $num;
 751         } else {
 752           ();
 753         }
 754       } map { { 'svcpart'  => $_->svcpart,
 755                 'quantity' => $_->quantity } }
 756           qsearch('pkg_svc', { pkgpart  => $pkgpart,
 757                                quantity => { op=>'>', value=>'0', } } )
 758     ];
 759   }
 760
 761   if ( $DEBUG ) {
 762     foreach my $svcpart ( keys %svcnum ) {
 763       warn "after regular move svcpart $svcpart: existing svcnums ".
 764            join(', ', map { $_->svcnum } @{$svcnum{$svcpart}} ). "\n";
 765     }
 766   }
 767
 768   #special-case until this can be handled better
 769   # move services to new svcparts - even if the svcparts don't match (svcdb
 770   # needs to...)
 771   # looks like they're moved in no particular order, ewwwwwwww
 772   # and looks like just one of each svcpart can be moved... o well
 773
 774   #start with still-leftover services
 775   #foreach my $svcpart ( grep { scalar(@{ $svcnum{$_} }) } keys %svcnum ) {
 776   foreach my $svcpart ( keys %svcnum ) {
 777     next unless @{ $svcnum{$svcpart} };
 778
 779     my $svcdb = $svcnum{$svcpart}->[0]->part_svc->svcdb;
 780
 781     #find an empty place to put one
 782     my $i = 0;
 783     foreach my $pkgpart ( @{$pkgparts} ) {
 784       my @pkg_svc =
 785         qsearch('pkg_svc', { pkgpart  => $pkgpart,
 786                              quantity => { op=>'>', value=>'0', } } );
 787       #my @pkg_svc =
 788       #  grep { $_->quantity > 0 } qsearch('pkg_svc', { pkgpart=>$pkgpart } );
 789       if ( ! @{$cust_svc[$i]} #find an empty place to put them with
 790            && grep { $svcdb eq $_->part_svc->svcdb } #with appropriate svcdb
 791                 @pkg_svc
 792       ) {
 793         my $new_svcpart =
 794           ( grep { $svcdb eq $_->part_svc->svcdb } @pkg_svc )[0]->svcpart;
 795         my $cust_svc = shift @{$svcnum{$svcpart}};
 796         $cust_svc->svcpart($new_svcpart);
 797         #warn "changing from $svcpart to $new_svcpart!!!\n";
 798         $cust_svc[$i] = [ $cust_svc ];
 799       }
 800       $i++;
 801     }
 802
 803   }
 804
 805   if ( $DEBUG ) {
 806     foreach my $svcpart ( keys %svcnum ) {
 807       warn "after special-case move svcpart $svcpart: existing svcnums ".
 808            join(', ', map { $_->svcnum } @{$svcnum{$svcpart}} ). "\n";
 809     }
 810   }
 811
 812
 813   #check for leftover services
 814   foreach (keys %svcnum) {
 815     next unless @{ $svcnum{$_} };
 816     $dbh->rollback if $oldAutoCommit;
 817     return "Leftover services, svcpart $_: svcnum ".
 818            join(', ', map { $_->svcnum } @{ $svcnum{$_} } );
 819   }
 820
 821   #no leftover services, let's make changes.
 822
 823   local $SIG{HUP} = 'IGNORE';
 824   local $SIG{INT} = 'IGNORE';
 825   local $SIG{QUIT} = 'IGNORE';
 826   local $SIG{TERM} = 'IGNORE';
 827   local $SIG{TSTP} = 'IGNORE';
 828   local $SIG{PIPE} = 'IGNORE';
 829
 830   #first cancel old packages
 831   foreach my $pkgnum ( @{$remove_pkgnums} ) {
 832     my($old) = qsearchs('cust_pkg',{'pkgnum'=>$pkgnum});
 833     unless ( $old ) {
 834       $dbh->rollback if $oldAutoCommit;
 835       return "Package $pkgnum not found to remove!";
 836     }
 837     my(%hash) = $old->hash;
 838     $hash{'cancel'}=time;
 839     my($new) = new FS::cust_pkg ( \%hash );
 840     my($error)=$new->replace($old);
 841     if ( $error ) {
 842       $dbh->rollback if $oldAutoCommit;
 843       return "Couldn't update package $pkgnum: $error";
 844     }
 845   }
 846
 847   #now add new packages, changing cust_svc records if necessary
 848   my $pkgpart;
 849   while ($pkgpart=shift @{$pkgparts} ) {
 850
 851     my $new = new FS::cust_pkg {
 852                                  'custnum' => $custnum,
 853                                  'pkgpart' => $pkgpart,
 854                                };
 855     my $error = $new->insert;
 856     if ( $error ) {
 857       $dbh->rollback if $oldAutoCommit;
 858       return "Couldn't insert new cust_pkg record: $error";
 859     }
 860     push @{$return_cust_pkg}, $new if $return_cust_pkg;
 861     my $pkgnum = $new->pkgnum;
 862
 863     foreach my $cust_svc ( @{ shift @cust_svc } ) {
 864       my(%hash) = $cust_svc->hash;
 865       $hash{'pkgnum'}=$pkgnum;
 866       my $new = new FS::cust_svc ( \%hash );
 867
 868       #avoid Record diffing missing changed svcpart field from above.
 869       my $old = qsearchs('cust_svc', { 'svcnum' => $cust_svc->svcnum } );
 870
 871       my $error = $new->replace($old);
 872       if ( $error ) {
 873         $dbh->rollback if $oldAutoCommit;
 874         return "Couldn't link old service to new package: $error";
 875       }
 876     }
 877   }
 878
 879   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 880
 881   ''; #no errors
 882 }
 883
 884 =back
 885
 886 =head1 BUGS
 887
 888 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
 889
 890 In sub order, the @pkgparts array (passed by reference) is clobbered.
 891
 892 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
 893 method to pass dates to the recur_prog expression, it should do so.
 894
 895 FS::svc_acct, FS::svc_acct_sm, and FS::svc_domain are loaded via 'use' at
 896 compile time, rather than via 'require' in sub { setup, suspend, unsuspend,
 897 cancel } because they use %FS::UID::callback to load configuration values.
 898 Probably need a subroutine which decides what to do based on whether or not
 899 we've fetched the user yet, rather than a hash.  See FS::UID and the TODO.
 900
 901 Now that things are transactional should the check in the insert method be
 902 moved to check ?
 903
 904 =head1 SEE ALSO
 905
 906 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
 907 L<FS::pkg_svc>, schema.html from the base documentation
 908
 909 =cut
 910
 911 1;
 912