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   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
 481                                                   'edate'  => $self->bill,  } );
 482   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
 483 }
 484
 485 =item part_pkg
 486
 487 Returns the definition for this billing item, as an FS::part_pkg object (see
 488 L<FS::part_pkg>).
 489
 490 =cut
 491
 492 sub part_pkg {
 493   my $self = shift;
 494   #exists( $self->{'_pkgpart'} )
 495   $self->{'_pkgpart'}
 496     ? $self->{'_pkgpart'}
 497     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 498 }
 499
 500 =item cust_svc
 501
 502 Returns the services for this package, as FS::cust_svc objects (see
 503 L<FS::cust_svc>)
 504
 505 =cut
 506
 507 sub cust_svc {
 508   my $self = shift;
 509   if ( $self->{'_svcnum'} ) {
 510     values %{ $self->{'_svcnum'}->cache };
 511   } else {
 512     qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } );
 513   }
 514 }
 515
 516 =item labels
 517
 518 Returns a list of lists, calling the label method for all services
 519 (see L<FS::cust_svc>) of this billing item.
 520
 521 =cut
 522
 523 sub labels {
 524   my $self = shift;
 525   map { [ $_->label ] } $self->cust_svc;
 526 }
 527
 528 =item cust_main
 529
 530 Returns the parent customer object (see L<FS::cust_main>).
 531
 532 =cut
 533
 534 sub cust_main {
 535   my $self = shift;
 536   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 537 }
 538
 539 =item seconds_since TIMESTAMP
 540
 541 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
 542 package have been online since TIMESTAMP, according to the session monitor.
 543
 544 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 545 L<Time::Local> and L<Date::Parse> for conversion functions.
 546
 547 =cut
 548
 549 sub seconds_since {
 550   my($self, $since) = @_;
 551   my $seconds = 0;
 552
 553   foreach my $cust_svc (
 554     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
 555   ) {
 556     $seconds += $cust_svc->seconds_since($since);
 557   }
 558
 559   $seconds;
 560
 561 }
 562
 563 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 564
 565 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
 566 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
 567 (exclusive).
 568
 569 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 570 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 571 functions.
 572
 573
 574 =cut
 575
 576 sub seconds_since_sqlradacct {
 577   my($self, $start, $end) = @_;
 578
 579   my $seconds = 0;
 580
 581   foreach my $cust_svc (
 582     grep {
 583       my $part_svc = $_->part_svc;
 584       $part_svc->svcdb eq 'svc_acct'
 585         && scalar($part_svc->part_export('sqlradius'));
 586     } $self->cust_svc
 587   ) {
 588     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
 589   }
 590
 591   $seconds;
 592
 593 }
 594
 595 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 596
 597 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
 598 in this package for sessions ending between TIMESTAMP_START (inclusive) and
 599 TIMESTAMP_END
 600 (exclusive).
 601
 602 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 603 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 604 functions.
 605
 606 =cut
 607
 608 sub attribute_since_sqlradacct {
 609   my($self, $start, $end, $attrib) = @_;
 610
 611   my $sum = 0;
 612
 613   foreach my $cust_svc (
 614     grep {
 615       my $part_svc = $_->part_svc;
 616       $part_svc->svcdb eq 'svc_acct'
 617         && scalar($part_svc->part_export('sqlradius'));
 618     } $self->cust_svc
 619   ) {
 620     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
 621   }
 622
 623   $sum;
 624
 625 }
 626
 627 =back
 628
 629 =head1 SUBROUTINES
 630
 631 =over 4
 632
 633 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
 634
 635 CUSTNUM is a customer (see L<FS::cust_main>)
 636
 637 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
 638 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
 639 permitted.
 640
 641 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
 642 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
 643 new billing items.  An error is returned if this is not possible (see
 644 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
 645 parameter.
 646
 647 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
 648 newly-created cust_pkg objects.
 649
 650 =cut
 651
 652 sub order {
 653   my($custnum, $pkgparts, $remove_pkgnums, $return_cust_pkg) = @_;
 654   $remove_pkgnums = [] unless defined($remove_pkgnums);
 655
 656   my $oldAutoCommit = $FS::UID::AutoCommit;
 657   local $FS::UID::AutoCommit = 0;
 658   my $dbh = dbh;
 659
 660   # generate %part_pkg
 661   # $part_pkg{$pkgpart} is true iff $custnum may purchase $pkgpart
 662   #
 663   my($cust_main)=qsearchs('cust_main',{'custnum'=>$custnum});
 664   my($agent)=qsearchs('agent',{'agentnum'=> $cust_main->agentnum });
 665   my %part_pkg = %{ $agent->pkgpart_hashref };
 666
 667   my(%svcnum);
 668   # generate %svcnum
 669   # for those packages being removed:
 670   #@{ $svcnum{$svcpart} } goes from a svcpart to a list of FS::cust_svc objects
 671   my($pkgnum);
 672   foreach $pkgnum ( @{$remove_pkgnums} ) {
 673     foreach my $cust_svc (qsearch('cust_svc',{'pkgnum'=>$pkgnum})) {
 674       push @{ $svcnum{$cust_svc->getfield('svcpart')} }, $cust_svc;
 675     }
 676   }
 677
 678   my @cust_svc;
 679   #generate @cust_svc
 680   # for those packages the customer is purchasing:
 681   # @{$pkgparts} is a list of said packages, by pkgpart
 682   # @cust_svc is a corresponding list of lists of FS::Record objects
 683   foreach my $pkgpart ( @{$pkgparts} ) {
 684     unless ( $part_pkg{$pkgpart} ) {
 685       $dbh->rollback if $oldAutoCommit;
 686       return "Customer not permitted to purchase pkgpart $pkgpart!";
 687     }
 688     push @cust_svc, [
 689       map {
 690         ( $svcnum{$_} && @{ $svcnum{$_} } ) ? shift @{ $svcnum{$_} } : ();
 691       } map { $_->svcpart }
 692           qsearch('pkg_svc', { pkgpart  => $pkgpart,
 693                                quantity => { op=>'>', value=>'0', } } )
 694     ];
 695   }
 696
 697   #special-case until this can be handled better
 698   # move services to new svcparts - even if the svcparts don't match (svcdb
 699   # needs to...)
 700   # looks like they're moved in no particular order, ewwwwwwww
 701   # and looks like just one of each svcpart can be moved... o well
 702
 703   #start with still-leftover services
 704   #foreach my $svcpart ( grep { scalar(@{ $svcnum{$_} }) } keys %svcnum ) {
 705   foreach my $svcpart ( keys %svcnum ) {
 706     next unless @{ $svcnum{$svcpart} };
 707
 708     my $svcdb = $svcnum{$svcpart}->[0]->part_svc->svcdb;
 709
 710     #find an empty place to put one
 711     my $i = 0;
 712     foreach my $pkgpart ( @{$pkgparts} ) {
 713       my @pkg_svc =
 714         qsearch('pkg_svc', { pkgpart  => $pkgpart,
 715                              quantity => { op=>'>', value=>'0', } } );
 716       #my @pkg_svc =
 717       #  grep { $_->quantity > 0 } qsearch('pkg_svc', { pkgpart=>$pkgpart } );
 718       if ( ! @{$cust_svc[$i]} #find an empty place to put them with
 719            && grep { $svcdb eq $_->part_svc->svcdb } #with appropriate svcdb
 720                 @pkg_svc
 721       ) {
 722         my $new_svcpart =
 723           ( grep { $svcdb eq $_->part_svc->svcdb } @pkg_svc )[0]->svcpart;
 724         my $cust_svc = shift @{$svcnum{$svcpart}};
 725         $cust_svc->svcpart($new_svcpart);
 726         #warn "changing from $svcpart to $new_svcpart!!!\n";
 727         $cust_svc[$i] = [ $cust_svc ];
 728       }
 729       $i++;
 730     }
 731
 732   }
 733
 734   #check for leftover services
 735   foreach (keys %svcnum) {
 736     next unless @{ $svcnum{$_} };
 737     $dbh->rollback if $oldAutoCommit;
 738     return "Leftover services, svcpart $_: svcnum ".
 739            join(', ', map { $_->svcnum } @{ $svcnum{$_} } );
 740   }
 741
 742   #no leftover services, let's make changes.
 743
 744   local $SIG{HUP} = 'IGNORE';
 745   local $SIG{INT} = 'IGNORE';
 746   local $SIG{QUIT} = 'IGNORE';
 747   local $SIG{TERM} = 'IGNORE';
 748   local $SIG{TSTP} = 'IGNORE';
 749   local $SIG{PIPE} = 'IGNORE';
 750
 751   #first cancel old packages
 752   foreach my $pkgnum ( @{$remove_pkgnums} ) {
 753     my($old) = qsearchs('cust_pkg',{'pkgnum'=>$pkgnum});
 754     unless ( $old ) {
 755       $dbh->rollback if $oldAutoCommit;
 756       return "Package $pkgnum not found to remove!";
 757     }
 758     my(%hash) = $old->hash;
 759     $hash{'cancel'}=time;
 760     my($new) = new FS::cust_pkg ( \%hash );
 761     my($error)=$new->replace($old);
 762     if ( $error ) {
 763       $dbh->rollback if $oldAutoCommit;
 764       return "Couldn't update package $pkgnum: $error";
 765     }
 766   }
 767
 768   #now add new packages, changing cust_svc records if necessary
 769   my $pkgpart;
 770   while ($pkgpart=shift @{$pkgparts} ) {
 771
 772     my $new = new FS::cust_pkg {
 773                                  'custnum' => $custnum,
 774                                  'pkgpart' => $pkgpart,
 775                                };
 776     my $error = $new->insert;
 777     if ( $error ) {
 778       $dbh->rollback if $oldAutoCommit;
 779       return "Couldn't insert new cust_pkg record: $error";
 780     }
 781     push @{$return_cust_pkg}, $new if $return_cust_pkg;
 782     my $pkgnum = $new->pkgnum;
 783
 784     foreach my $cust_svc ( @{ shift @cust_svc } ) {
 785       my(%hash) = $cust_svc->hash;
 786       $hash{'pkgnum'}=$pkgnum;
 787       my $new = new FS::cust_svc ( \%hash );
 788
 789       #avoid Record diffing missing changed svcpart field from above.
 790       my $old = qsearchs('cust_svc', { 'svcnum' => $cust_svc->svcnum } );
 791
 792       my $error = $new->replace($old);
 793       if ( $error ) {
 794         $dbh->rollback if $oldAutoCommit;
 795         return "Couldn't link old service to new package: $error";
 796       }
 797     }
 798   }
 799
 800   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 801
 802   ''; #no errors
 803 }
 804
 805 =back
 806
 807 =head1 BUGS
 808
 809 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
 810
 811 In sub order, the @pkgparts array (passed by reference) is clobbered.
 812
 813 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
 814 method to pass dates to the recur_prog expression, it should do so.
 815
 816 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
 817 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
 818 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
 819 configuration values.  Probably need a subroutine which decides what to do
 820 based on whether or not we've fetched the user yet, rather than a hash.  See
 821 FS::UID and the TODO.
 822
 823 Now that things are transactional should the check in the insert method be
 824 moved to check ?
 825
 826 =head1 SEE ALSO
 827
 828 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
 829 L<FS::pkg_svc>, schema.html from the base documentation
 830
 831 =cut
 832
 833 1;
 834