FS/FS/cust_pkg.pm

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