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