FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2
   3 use strict;
   4 use vars qw(@ISA $disable_agentcheck);
   5 use vars qw( $quiet );
   6 use FS::UID qw( getotaker dbh );
   7 use FS::Record qw( qsearch qsearchs );
   8 use FS::cust_svc;
   9 use FS::part_pkg;
  10 use FS::cust_main;
  11 use FS::type_pkgs;
  12 use FS::pkg_svc;
  13 use FS::cust_bill_pkg;
  14
  15 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  16 # setup }
  17 # because they load configuraion by setting FS::UID::callback (see TODO)
  18 use FS::svc_acct;
  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
 604 (exclusive).
 605
 606 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 607 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 608 functions.
 609
 610 =cut
 611
 612 sub attribute_since_sqlradacct {
 613   my($self, $start, $end, $attrib) = @_;
 614
 615   my $sum = 0;
 616
 617   foreach my $cust_svc (
 618     grep {
 619       my $part_svc = $_->part_svc;
 620       $part_svc->svcdb eq 'svc_acct'
 621         && scalar($part_svc->part_export('sqlradius'));
 622     } $self->cust_svc
 623   ) {
 624     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
 625   }
 626
 627   $sum;
 628
 629 }
 630
 631 =back
 632
 633 =head1 SUBROUTINES
 634
 635 =over 4
 636
 637 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
 638
 639 CUSTNUM is a customer (see L<FS::cust_main>)
 640
 641 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
 642 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
 643 permitted.
 644
 645 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
 646 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
 647 new billing items.  An error is returned if this is not possible (see
 648 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
 649 parameter.
 650
 651 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
 652 newly-created cust_pkg objects.
 653
 654 =cut
 655
 656 sub order {
 657   my($custnum, $pkgparts, $remove_pkgnums, $return_cust_pkg) = @_;
 658   $remove_pkgnums = [] unless defined($remove_pkgnums);
 659
 660   my $oldAutoCommit = $FS::UID::AutoCommit;
 661   local $FS::UID::AutoCommit = 0;
 662   my $dbh = dbh;
 663
 664   # generate %part_pkg
 665   # $part_pkg{$pkgpart} is true iff $custnum may purchase $pkgpart
 666   #
 667   my($cust_main)=qsearchs('cust_main',{'custnum'=>$custnum});
 668   my($agent)=qsearchs('agent',{'agentnum'=> $cust_main->agentnum });
 669   my %part_pkg = %{ $agent->pkgpart_hashref };
 670
 671   my(%svcnum);
 672   # generate %svcnum
 673   # for those packages being removed:
 674   #@{ $svcnum{$svcpart} } goes from a svcpart to a list of FS::cust_svc objects
 675   my($pkgnum);
 676   foreach $pkgnum ( @{$remove_pkgnums} ) {
 677     foreach my $cust_svc (qsearch('cust_svc',{'pkgnum'=>$pkgnum})) {
 678       push @{ $svcnum{$cust_svc->getfield('svcpart')} }, $cust_svc;
 679     }
 680   }
 681
 682   my @cust_svc;
 683   #generate @cust_svc
 684   # for those packages the customer is purchasing:
 685   # @{$pkgparts} is a list of said packages, by pkgpart
 686   # @cust_svc is a corresponding list of lists of FS::Record objects
 687   foreach my $pkgpart ( @{$pkgparts} ) {
 688     unless ( $part_pkg{$pkgpart} ) {
 689       $dbh->rollback if $oldAutoCommit;
 690       return "Customer not permitted to purchase pkgpart $pkgpart!";
 691     }
 692     push @cust_svc, [
 693       map {
 694         ( $svcnum{$_} && @{ $svcnum{$_} } ) ? shift @{ $svcnum{$_} } : ();
 695       } map { $_->svcpart }
 696           qsearch('pkg_svc', { pkgpart  => $pkgpart,
 697                                quantity => { op=>'>', value=>'0', } } )
 698     ];
 699   }
 700
 701   #special-case until this can be handled better
 702   # move services to new svcparts - even if the svcparts don't match (svcdb
 703   # needs to...)
 704   # looks like they're moved in no particular order, ewwwwwwww
 705   # and looks like just one of each svcpart can be moved... o well
 706
 707   #start with still-leftover services
 708   #foreach my $svcpart ( grep { scalar(@{ $svcnum{$_} }) } keys %svcnum ) {
 709   foreach my $svcpart ( keys %svcnum ) {
 710     next unless @{ $svcnum{$svcpart} };
 711
 712     my $svcdb = $svcnum{$svcpart}->[0]->part_svc->svcdb;
 713
 714     #find an empty place to put one
 715     my $i = 0;
 716     foreach my $pkgpart ( @{$pkgparts} ) {
 717       my @pkg_svc =
 718         qsearch('pkg_svc', { pkgpart  => $pkgpart,
 719                              quantity => { op=>'>', value=>'0', } } );
 720       #my @pkg_svc =
 721       #  grep { $_->quantity > 0 } qsearch('pkg_svc', { pkgpart=>$pkgpart } );
 722       if ( ! @{$cust_svc[$i]} #find an empty place to put them with
 723            && grep { $svcdb eq $_->part_svc->svcdb } #with appropriate svcdb
 724                 @pkg_svc
 725       ) {
 726         my $new_svcpart =
 727           ( grep { $svcdb eq $_->part_svc->svcdb } @pkg_svc )[0]->svcpart;
 728         my $cust_svc = shift @{$svcnum{$svcpart}};
 729         $cust_svc->svcpart($new_svcpart);
 730         #warn "changing from $svcpart to $new_svcpart!!!\n";
 731         $cust_svc[$i] = [ $cust_svc ];
 732       }
 733       $i++;
 734     }
 735
 736   }
 737
 738   #check for leftover services
 739   foreach (keys %svcnum) {
 740     next unless @{ $svcnum{$_} };
 741     $dbh->rollback if $oldAutoCommit;
 742     return "Leftover services, svcpart $_: svcnum ".
 743            join(', ', map { $_->svcnum } @{ $svcnum{$_} } );
 744   }
 745
 746   #no leftover services, let's make changes.
 747
 748   local $SIG{HUP} = 'IGNORE';
 749   local $SIG{INT} = 'IGNORE';
 750   local $SIG{QUIT} = 'IGNORE';
 751   local $SIG{TERM} = 'IGNORE';
 752   local $SIG{TSTP} = 'IGNORE';
 753   local $SIG{PIPE} = 'IGNORE';
 754
 755   #first cancel old packages
 756   foreach my $pkgnum ( @{$remove_pkgnums} ) {
 757     my($old) = qsearchs('cust_pkg',{'pkgnum'=>$pkgnum});
 758     unless ( $old ) {
 759       $dbh->rollback if $oldAutoCommit;
 760       return "Package $pkgnum not found to remove!";
 761     }
 762     my(%hash) = $old->hash;
 763     $hash{'cancel'}=time;
 764     my($new) = new FS::cust_pkg ( \%hash );
 765     my($error)=$new->replace($old);
 766     if ( $error ) {
 767       $dbh->rollback if $oldAutoCommit;
 768       return "Couldn't update package $pkgnum: $error";
 769     }
 770   }
 771
 772   #now add new packages, changing cust_svc records if necessary
 773   my $pkgpart;
 774   while ($pkgpart=shift @{$pkgparts} ) {
 775
 776     my $new = new FS::cust_pkg {
 777                                  'custnum' => $custnum,
 778                                  'pkgpart' => $pkgpart,
 779                                };
 780     my $error = $new->insert;
 781     if ( $error ) {
 782       $dbh->rollback if $oldAutoCommit;
 783       return "Couldn't insert new cust_pkg record: $error";
 784     }
 785     push @{$return_cust_pkg}, $new if $return_cust_pkg;
 786     my $pkgnum = $new->pkgnum;
 787
 788     foreach my $cust_svc ( @{ shift @cust_svc } ) {
 789       my(%hash) = $cust_svc->hash;
 790       $hash{'pkgnum'}=$pkgnum;
 791       my $new = new FS::cust_svc ( \%hash );
 792
 793       #avoid Record diffing missing changed svcpart field from above.
 794       my $old = qsearchs('cust_svc', { 'svcnum' => $cust_svc->svcnum } );
 795
 796       my $error = $new->replace($old);
 797       if ( $error ) {
 798         $dbh->rollback if $oldAutoCommit;
 799         return "Couldn't link old service to new package: $error";
 800       }
 801     }
 802   }
 803
 804   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 805
 806   ''; #no errors
 807 }
 808
 809 =back
 810
 811 =head1 BUGS
 812
 813 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
 814
 815 In sub order, the @pkgparts array (passed by reference) is clobbered.
 816
 817 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
 818 method to pass dates to the recur_prog expression, it should do so.
 819
 820 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
 821 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
 822 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
 823 configuration values.  Probably need a subroutine which decides what to do
 824 based on whether or not we've fetched the user yet, rather than a hash.  See
 825 FS::UID and the TODO.
 826
 827 Now that things are transactional should the check in the insert method be
 828 moved to check ?
 829
 830 =head1 SEE ALSO
 831
 832 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
 833 L<FS::pkg_svc>, schema.html from the base documentation
 834
 835 =cut
 836
 837 1;
 838