FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2
   3 use strict;
   4 use vars qw(@ISA $disable_agentcheck $DEBUG);
   5 use FS::UID qw( getotaker dbh );
   6 use FS::Record qw( qsearch qsearchs );
   7 use FS::cust_svc;
   8 use FS::part_pkg;
   9 use FS::cust_main;
  10 use FS::type_pkgs;
  11 use FS::pkg_svc;
  12 use FS::cust_bill_pkg;
  13
  14 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  15 # setup }
  16 # because they load configuraion by setting FS::UID::callback (see TODO)
  17 use FS::svc_acct;
  18 use FS::svc_acct_sm;
  19 use FS::svc_domain;
  20 use FS::svc_www;
  21 use FS::svc_forward;
  22
  23 # need all this for sending cancel emails in sub cancel
  24
  25 use FS::Conf;
  26 use Date::Format;
  27 use Mail::Internet 1.44;
  28 use Mail::Header;
  29
  30 @ISA = qw( FS::Record );
  31
  32 $DEBUG = 0;
  33
  34 $disable_agentcheck = 0;
  35
  36 sub _cache {
  37   my $self = shift;
  38   my ( $hashref, $cache ) = @_;
  39   #if ( $hashref->{'pkgpart'} ) {
  40   if ( $hashref->{'pkg'} ) {
  41     # #@{ $self->{'_pkgnum'} } = ();
  42     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  43     # $self->{'_pkgpart'} = $subcache;
  44     # #push @{ $self->{'_pkgnum'} },
  45     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  46     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  47   }
  48   if ( exists $hashref->{'svcnum'} ) {
  49     #@{ $self->{'_pkgnum'} } = ();
  50     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  51     $self->{'_svcnum'} = $subcache;
  52     #push @{ $self->{'_pkgnum'} },
  53     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  54   }
  55 }
  56
  57 =head1 NAME
  58
  59 FS::cust_pkg - Object methods for cust_pkg objects
  60
  61 =head1 SYNOPSIS
  62
  63   use FS::cust_pkg;
  64
  65   $record = new FS::cust_pkg \%hash;
  66   $record = new FS::cust_pkg { 'column' => 'value' };
  67
  68   $error = $record->insert;
  69
  70   $error = $new_record->replace($old_record);
  71
  72   $error = $record->delete;
  73
  74   $error = $record->check;
  75
  76   $error = $record->cancel;
  77
  78   $error = $record->suspend;
  79
  80   $error = $record->unsuspend;
  81
  82   $part_pkg = $record->part_pkg;
  83
  84   @labels = $record->labels;
  85
  86   $seconds = $record->seconds_since($timestamp);
  87
  88   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
  89   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
  90
  91 =head1 DESCRIPTION
  92
  93 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
  94 inherits from FS::Record.  The following fields are currently supported:
  95
  96 =over 4
  97
  98 =item pkgnum - primary key (assigned automatically for new billing items)
  99
 100 =item custnum - Customer (see L<FS::cust_main>)
 101
 102 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
 103
 104 =item setup - date
 105
 106 =item bill - date (next bill date)
 107
 108 =item susp - date
 109
 110 =item expire - date
 111
 112 =item cancel - date
 113
 114 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
 115
 116 =item manual_flag - If this field is set to 1, disables the automatic
 117 unsuspension of this package when using the B<unsuspendauto> config file.
 118
 119 =back
 120
 121 Note: setup, bill, susp, expire and cancel are specified as UNIX timestamps;
 122 see L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for
 123 conversion functions.
 124
 125 =head1 METHODS
 126
 127 =over 4
 128
 129 =item new HASHREF
 130
 131 Create a new billing item.  To add the item to the database, see L<"insert">.
 132
 133 =cut
 134
 135 sub table { 'cust_pkg'; }
 136
 137 =item insert
 138
 139 Adds this billing item to the database ("Orders" the item).  If there is an
 140 error, returns the error, otherwise returns false.
 141
 142 =cut
 143
 144 sub insert {
 145   my $self = shift;
 146
 147   # custnum might not have have been defined in sub check (for one-shot new
 148   # customers), so check it here instead
 149   # (is this still necessary with transactions?)
 150
 151   my $error = $self->ut_number('custnum');
 152   return $error if $error;
 153
 154   my $cust_main = $self->cust_main;
 155   return "Unknown custnum: ". $self->custnum unless $cust_main;
 156
 157   unless ( $disable_agentcheck ) {
 158     my $agent = qsearchs( 'agent', { 'agentnum' => $cust_main->agentnum } );
 159     my $pkgpart_href = $agent->pkgpart_hashref;
 160     return "agent ". $agent->agentnum.
 161            " can't purchase pkgpart ". $self->pkgpart
 162       unless $pkgpart_href->{ $self->pkgpart };
 163   }
 164
 165   $self->SUPER::insert;
 166
 167 }
 168
 169 =item delete
 170
 171 This method now works but you probably shouldn't use it.
 172
 173 You don't want to delete billing items, because there would then be no record
 174 the customer ever purchased the item.  Instead, see the cancel method.
 175
 176 =cut
 177
 178 #sub delete {
 179 #  return "Can't delete cust_pkg records!";
 180 #}
 181
 182 =item replace OLD_RECORD
 183
 184 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 185 returns the error, otherwise returns false.
 186
 187 Currently, custnum, setup, bill, susp, expire, and cancel may be changed.
 188
 189 Changing pkgpart may have disasterous effects.  See the order subroutine.
 190
 191 setup and bill are normally updated by calling the bill method of a customer
 192 object (see L<FS::cust_main>).
 193
 194 suspend is normally updated by the suspend and unsuspend methods.
 195
 196 cancel is normally updated by the cancel method (and also the order subroutine
 197 in some cases).
 198
 199 =cut
 200
 201 sub replace {
 202   my( $new, $old ) = ( shift, shift );
 203
 204   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 205   return "Can't change otaker!" if $old->otaker ne $new->otaker;
 206
 207   #allow this *sigh*
 208   #return "Can't change setup once it exists!"
 209   #  if $old->getfield('setup') &&
 210   #     $old->getfield('setup') != $new->getfield('setup');
 211
 212   #some logic for bill, susp, cancel?
 213
 214   $new->SUPER::replace($old);
 215 }
 216
 217 =item check
 218
 219 Checks all fields to make sure this is a valid billing item.  If there is an
 220 error, returns the error, otherwise returns false.  Called by the insert and
 221 replace methods.
 222
 223 =cut
 224
 225 sub check {
 226   my $self = shift;
 227
 228   my $error =
 229     $self->ut_numbern('pkgnum')
 230     || $self->ut_numbern('custnum')
 231     || $self->ut_number('pkgpart')
 232     || $self->ut_numbern('setup')
 233     || $self->ut_numbern('bill')
 234     || $self->ut_numbern('susp')
 235     || $self->ut_numbern('cancel')
 236   ;
 237   return $error if $error;
 238
 239   if ( $self->custnum ) {
 240     return "Unknown customer ". $self->custnum unless $self->cust_main;
 241   }
 242
 243   return "Unknown pkgpart: ". $self->pkgpart
 244     unless qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 245
 246   $self->otaker(getotaker) unless $self->otaker;
 247   $self->otaker =~ /^([\w\.\-]{0,16})$/ or return "Illegal otaker";
 248   $self->otaker($1);
 249
 250   if ( $self->dbdef_table->column('manual_flag') ) {
 251     $self->manual_flag('') if $self->manual_flag eq ' ';
 252     $self->manual_flag =~ /^([01]?)$/
 253       or return "Illegal manual_flag ". $self->manual_flag;
 254     $self->manual_flag($1);
 255   }
 256
 257   ''; #no error
 258 }
 259
 260 =item cancel [ OPTION => VALUE ... ]
 261
 262 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 263 in this package, then cancels the package itself (sets the cancel field to
 264 now).
 265
 266 Available options are: I<quiet>
 267
 268 I<quiet> can be set true to supress email cancellation notices.
 269
 270 If there is an error, returns the error, otherwise returns false.
 271
 272 =cut
 273
 274 sub cancel {
 275   my( $self, %options ) = @_;
 276   my $error;
 277
 278   local $SIG{HUP} = 'IGNORE';
 279   local $SIG{INT} = 'IGNORE';
 280   local $SIG{QUIT} = 'IGNORE';
 281   local $SIG{TERM} = 'IGNORE';
 282   local $SIG{TSTP} = 'IGNORE';
 283   local $SIG{PIPE} = 'IGNORE';
 284
 285   my $oldAutoCommit = $FS::UID::AutoCommit;
 286   local $FS::UID::AutoCommit = 0;
 287   my $dbh = dbh;
 288
 289   foreach my $cust_svc (
 290     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 291   ) {
 292     my $error = $cust_svc->cancel;
 293
 294     if ( $error ) {
 295       $dbh->rollback if $oldAutoCommit;
 296       return "Error cancelling cust_svc: $error";
 297     }
 298
 299   }
 300
 301   unless ( $self->getfield('cancel') ) {
 302     my %hash = $self->hash;
 303     $hash{'cancel'} = time;
 304     my $new = new FS::cust_pkg ( \%hash );
 305     $error = $new->replace($self);
 306     if ( $error ) {
 307       $dbh->rollback if $oldAutoCommit;
 308       return $error;
 309     }
 310   }
 311
 312   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 313
 314   my $conf = new FS::Conf;
 315
 316   if ( !$options{'quiet'} && $conf->exists('emailcancel')
 317        && grep { $_ ne 'POST' } $self->cust_main->invoicing_list) {
 318
 319       my @invoicing_list = $self->cust_main->invoicing_list;
 320
 321       my $invoice_from = $conf->config('invoice_from');
 322       my @print_text = map "$_\n", $conf->config('cancelmessage');
 323       my $subject = $conf->config('cancelsubject');
 324       my $smtpmachine = $conf->config('smtpmachine');
 325
 326       if ( grep { $_ ne 'POST' } @invoicing_list ) { #email invoice
 327           #false laziness w/FS::cust_pay::delete & fs_signup_server && ::realtime_card
 328           #$ENV{SMTPHOSTS} = $smtpmachine;
 329           $ENV{MAILADDRESS} = $invoice_from;
 330           my $header = new Mail::Header ( [
 331               "From: $invoice_from",
 332               "To: ". join(', ', grep { $_ ne 'POST' } @invoicing_list ),
 333               "Sender: $invoice_from",
 334               "Reply-To: $invoice_from",
 335               "Date: ". time2str("%a, %d %b %Y %X %z", time),
 336               "Subject: $subject",
 337                                      ] );
 338           my $message = new Mail::Internet (
 339               'Header' => $header,
 340               'Body' => [ @print_text ],
 341                                       );
 342           $!=0;
 343           $message->smtpsend( Host => $smtpmachine )
 344               or $message->smtpsend( Host => $smtpmachine, Debug => 1 );
 345           #should this return an error?
 346           }
 347   }
 348
 349   ''; #no errors
 350
 351 }
 352
 353 =item suspend
 354
 355 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 356 package, then suspends the package itself (sets the susp field to now).
 357
 358 If there is an error, returns the error, otherwise returns false.
 359
 360 =cut
 361
 362 sub suspend {
 363   my $self = shift;
 364   my $error ;
 365
 366   local $SIG{HUP} = 'IGNORE';
 367   local $SIG{INT} = 'IGNORE';
 368   local $SIG{QUIT} = 'IGNORE';
 369   local $SIG{TERM} = 'IGNORE';
 370   local $SIG{TSTP} = 'IGNORE';
 371   local $SIG{PIPE} = 'IGNORE';
 372
 373   my $oldAutoCommit = $FS::UID::AutoCommit;
 374   local $FS::UID::AutoCommit = 0;
 375   my $dbh = dbh;
 376
 377   foreach my $cust_svc (
 378     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 379   ) {
 380     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 381
 382     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 383       $dbh->rollback if $oldAutoCommit;
 384       return "Illegal svcdb value in part_svc!";
 385     };
 386     my $svcdb = $1;
 387     require "FS/$svcdb.pm";
 388
 389     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 390     if ($svc) {
 391       $error = $svc->suspend;
 392       if ( $error ) {
 393         $dbh->rollback if $oldAutoCommit;
 394         return $error;
 395       }
 396     }
 397
 398   }
 399
 400   unless ( $self->getfield('susp') ) {
 401     my %hash = $self->hash;
 402     $hash{'susp'} = time;
 403     my $new = new FS::cust_pkg ( \%hash );
 404     $error = $new->replace($self);
 405     if ( $error ) {
 406       $dbh->rollback if $oldAutoCommit;
 407       return $error;
 408     }
 409   }
 410
 411   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 412
 413   ''; #no errors
 414 }
 415
 416 =item unsuspend
 417
 418 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 419 package, then unsuspends the package itself (clears the susp field).
 420
 421 If there is an error, returns the error, otherwise returns false.
 422
 423 =cut
 424
 425 sub unsuspend {
 426   my $self = shift;
 427   my($error);
 428
 429   local $SIG{HUP} = 'IGNORE';
 430   local $SIG{INT} = 'IGNORE';
 431   local $SIG{QUIT} = 'IGNORE';
 432   local $SIG{TERM} = 'IGNORE';
 433   local $SIG{TSTP} = 'IGNORE';
 434   local $SIG{PIPE} = 'IGNORE';
 435
 436   my $oldAutoCommit = $FS::UID::AutoCommit;
 437   local $FS::UID::AutoCommit = 0;
 438   my $dbh = dbh;
 439
 440   foreach my $cust_svc (
 441     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
 442   ) {
 443     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 444
 445     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 446       $dbh->rollback if $oldAutoCommit;
 447       return "Illegal svcdb value in part_svc!";
 448     };
 449     my $svcdb = $1;
 450     require "FS/$svcdb.pm";
 451
 452     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 453     if ($svc) {
 454       $error = $svc->unsuspend;
 455       if ( $error ) {
 456         $dbh->rollback if $oldAutoCommit;
 457         return $error;
 458       }
 459     }
 460
 461   }
 462
 463   unless ( ! $self->getfield('susp') ) {
 464     my %hash = $self->hash;
 465     my $inactive = time - $hash{'susp'};
 466     $hash{'susp'} = '';
 467     $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
 468       if $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
 469     my $new = new FS::cust_pkg ( \%hash );
 470     $error = $new->replace($self);
 471     if ( $error ) {
 472       $dbh->rollback if $oldAutoCommit;
 473       return $error;
 474     }
 475   }
 476
 477   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 478
 479   ''; #no errors
 480 }
 481
 482 =item last_bill
 483
 484 Returns the last bill date, or if there is no last bill date, the setup date.
 485 Useful for billing metered services.
 486
 487 =cut
 488
 489 sub last_bill {
 490   my $self = shift;
 491   if ( $self->dbdef_table->column('last_bill') ) {
 492     return $self->setfield('last_bill', $_[1]) if @_;
 493     return $self->getfield('last_bill') if $self->getfield('last_bill');
 494   }
 495   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
 496                                                   'edate'  => $self->bill,  } );
 497   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
 498 }
 499
 500 =item part_pkg
 501
 502 Returns the definition for this billing item, as an FS::part_pkg object (see
 503 L<FS::part_pkg>).
 504
 505 =cut
 506
 507 sub part_pkg {
 508   my $self = shift;
 509   #exists( $self->{'_pkgpart'} )
 510   $self->{'_pkgpart'}
 511     ? $self->{'_pkgpart'}
 512     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 513 }
 514
 515 =item cust_svc
 516
 517 Returns the services for this package, as FS::cust_svc objects (see
 518 L<FS::cust_svc>)
 519
 520 =cut
 521
 522 sub cust_svc {
 523   my $self = shift;
 524   if ( $self->{'_svcnum'} ) {
 525     values %{ $self->{'_svcnum'}->cache };
 526   } else {
 527     qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } );
 528   }
 529 }
 530
 531 =item labels
 532
 533 Returns a list of lists, calling the label method for all services
 534 (see L<FS::cust_svc>) of this billing item.
 535
 536 =cut
 537
 538 sub labels {
 539   my $self = shift;
 540   map { [ $_->label ] } $self->cust_svc;
 541 }
 542
 543 =item cust_main
 544
 545 Returns the parent customer object (see L<FS::cust_main>).
 546
 547 =cut
 548
 549 sub cust_main {
 550   my $self = shift;
 551   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 552 }
 553
 554 =item seconds_since TIMESTAMP
 555
 556 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
 557 package have been online since TIMESTAMP, according to the session monitor.
 558
 559 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 560 L<Time::Local> and L<Date::Parse> for conversion functions.
 561
 562 =cut
 563
 564 sub seconds_since {
 565   my($self, $since) = @_;
 566   my $seconds = 0;
 567
 568   foreach my $cust_svc (
 569     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
 570   ) {
 571     $seconds += $cust_svc->seconds_since($since);
 572   }
 573
 574   $seconds;
 575
 576 }
 577
 578 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 579
 580 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
 581 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
 582 (exclusive).
 583
 584 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 585 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 586 functions.
 587
 588
 589 =cut
 590
 591 sub seconds_since_sqlradacct {
 592   my($self, $start, $end) = @_;
 593
 594   my $seconds = 0;
 595
 596   foreach my $cust_svc (
 597     grep {
 598       my $part_svc = $_->part_svc;
 599       $part_svc->svcdb eq 'svc_acct'
 600         && scalar($part_svc->part_export('sqlradius'));
 601     } $self->cust_svc
 602   ) {
 603     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
 604   }
 605
 606   $seconds;
 607
 608 }
 609
 610 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 611
 612 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
 613 in this package for sessions ending between TIMESTAMP_START (inclusive) and
 614 TIMESTAMP_END (exclusive).
 615
 616 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 617 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 618 functions.
 619
 620 =cut
 621
 622 sub attribute_since_sqlradacct {
 623   my($self, $start, $end, $attrib) = @_;
 624
 625   my $sum = 0;
 626
 627   foreach my $cust_svc (
 628     grep {
 629       my $part_svc = $_->part_svc;
 630       $part_svc->svcdb eq 'svc_acct'
 631         && scalar($part_svc->part_export('sqlradius'));
 632     } $self->cust_svc
 633   ) {
 634     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
 635   }
 636
 637   $sum;
 638
 639 }
 640
 641 =item reexport
 642
 643 This method is deprecated.  See the I<depend_jobnum> option to the insert and
 644 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
 645
 646 =cut
 647
 648 sub reexport {
 649   my $self = shift;
 650
 651   local $SIG{HUP} = 'IGNORE';
 652   local $SIG{INT} = 'IGNORE';
 653   local $SIG{QUIT} = 'IGNORE';
 654   local $SIG{TERM} = 'IGNORE';
 655   local $SIG{TSTP} = 'IGNORE';
 656   local $SIG{PIPE} = 'IGNORE';
 657
 658   my $oldAutoCommit = $FS::UID::AutoCommit;
 659   local $FS::UID::AutoCommit = 0;
 660   my $dbh = dbh;
 661
 662   foreach my $cust_svc ( $self->cust_svc ) {
 663     #false laziness w/svc_Common::insert
 664     my $svc_x = $cust_svc->svc_x;
 665     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
 666       my $error = $part_export->export_insert($svc_x);
 667       if ( $error ) {
 668         $dbh->rollback if $oldAutoCommit;
 669         return $error;
 670       }
 671     }
 672   }
 673
 674   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 675   '';
 676
 677 }
 678
 679 =back
 680
 681 =head1 SUBROUTINES
 682
 683 =over 4
 684
 685 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
 686
 687 CUSTNUM is a customer (see L<FS::cust_main>)
 688
 689 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
 690 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
 691 permitted.
 692
 693 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
 694 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
 695 new billing items.  An error is returned if this is not possible (see
 696 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
 697 parameter.
 698
 699 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
 700 newly-created cust_pkg objects.
 701
 702 =cut
 703
 704 sub order {
 705   my($custnum, $pkgparts, $remove_pkgnums, $return_cust_pkg) = @_;
 706   $remove_pkgnums = [] unless defined($remove_pkgnums);
 707
 708   my $oldAutoCommit = $FS::UID::AutoCommit;
 709   local $FS::UID::AutoCommit = 0;
 710   my $dbh = dbh;
 711
 712   # generate %part_pkg
 713   # $part_pkg{$pkgpart} is true iff $custnum may purchase $pkgpart
 714   #
 715   my($cust_main)=qsearchs('cust_main',{'custnum'=>$custnum});
 716   my($agent)=qsearchs('agent',{'agentnum'=> $cust_main->agentnum });
 717   my %part_pkg = %{ $agent->pkgpart_hashref };
 718
 719   my(%svcnum);
 720   # generate %svcnum
 721   # for those packages being removed:
 722   #@{ $svcnum{$svcpart} } goes from a svcpart to a list of FS::cust_svc objects
 723   my($pkgnum);
 724   foreach $pkgnum ( @{$remove_pkgnums} ) {
 725     foreach my $cust_svc (qsearch('cust_svc',{'pkgnum'=>$pkgnum})) {
 726       push @{ $svcnum{$cust_svc->getfield('svcpart')} }, $cust_svc;
 727     }
 728   }
 729   if ( $DEBUG ) {
 730     foreach my $svcpart ( keys %svcnum ) {
 731       warn "initial svcpart $svcpart: existing svcnums ".
 732            join(', ', map { $_->svcnum } @{$svcnum{$svcpart}} ). "\n";
 733     }
 734   }
 735
 736   my @cust_svc;
 737   #generate @cust_svc
 738   # for those packages the customer is purchasing:
 739   # @{$pkgparts} is a list of said packages, by pkgpart
 740   # @cust_svc is a corresponding list of lists of FS::Record objects
 741   foreach my $pkgpart ( @{$pkgparts} ) {
 742     unless ( $part_pkg{$pkgpart} ) {
 743       $dbh->rollback if $oldAutoCommit;
 744       return "Customer not permitted to purchase pkgpart $pkgpart!";
 745     }
 746     push @cust_svc, [
 747       map {
 748         my $svcnum = $svcnum{$_->{svcpart}};
 749         if ( $svcnum && @$svcnum ) {
 750           my $num = ( $_->{quantity} < scalar(@$svcnum) )
 751                       ? $_->{quantity}
 752                       : scalar(@$svcnum);
 753           splice @$svcnum, 0, $num;
 754         } else {
 755           ();
 756         }
 757       } map { { 'svcpart'  => $_->svcpart,
 758                 'quantity' => $_->quantity } }
 759           qsearch('pkg_svc', { pkgpart  => $pkgpart,
 760                                quantity => { op=>'>', value=>'0', } } )
 761     ];
 762   }
 763
 764   if ( $DEBUG ) {
 765     foreach my $svcpart ( keys %svcnum ) {
 766       warn "after regular move svcpart $svcpart: existing svcnums ".
 767            join(', ', map { $_->svcnum } @{$svcnum{$svcpart}} ). "\n";
 768     }
 769   }
 770
 771   #special-case until this can be handled better
 772   # move services to new svcparts - even if the svcparts don't match (svcdb
 773   # needs to...)
 774   # looks like they're moved in no particular order, ewwwwwwww
 775   # and looks like just one of each svcpart can be moved... o well
 776
 777   #start with still-leftover services
 778   #foreach my $svcpart ( grep { scalar(@{ $svcnum{$_} }) } keys %svcnum ) {
 779   foreach my $svcpart ( keys %svcnum ) {
 780     next unless @{ $svcnum{$svcpart} };
 781
 782     my $svcdb = $svcnum{$svcpart}->[0]->part_svc->svcdb;
 783
 784     #find an empty place to put one
 785     my $i = 0;
 786     foreach my $pkgpart ( @{$pkgparts} ) {
 787       my @pkg_svc =
 788         qsearch('pkg_svc', { pkgpart  => $pkgpart,
 789                              quantity => { op=>'>', value=>'0', } } );
 790       #my @pkg_svc =
 791       #  grep { $_->quantity > 0 } qsearch('pkg_svc', { pkgpart=>$pkgpart } );
 792       if ( ! @{$cust_svc[$i]} #find an empty place to put them with
 793            && grep { $svcdb eq $_->part_svc->svcdb } #with appropriate svcdb
 794                 @pkg_svc
 795       ) {
 796         my $new_svcpart =
 797           ( grep { $svcdb eq $_->part_svc->svcdb } @pkg_svc )[0]->svcpart;
 798         my $cust_svc = shift @{$svcnum{$svcpart}};
 799         $cust_svc->svcpart($new_svcpart);
 800         #warn "changing from $svcpart to $new_svcpart!!!\n";
 801         $cust_svc[$i] = [ $cust_svc ];
 802       }
 803       $i++;
 804     }
 805
 806   }
 807
 808   if ( $DEBUG ) {
 809     foreach my $svcpart ( keys %svcnum ) {
 810       warn "after special-case move svcpart $svcpart: existing svcnums ".
 811            join(', ', map { $_->svcnum } @{$svcnum{$svcpart}} ). "\n";
 812     }
 813   }
 814
 815
 816   #check for leftover services
 817   foreach (keys %svcnum) {
 818     next unless @{ $svcnum{$_} };
 819     $dbh->rollback if $oldAutoCommit;
 820     return "Leftover services, svcpart $_: svcnum ".
 821            join(', ', map { $_->svcnum } @{ $svcnum{$_} } );
 822   }
 823
 824   #no leftover services, let's make changes.
 825
 826   local $SIG{HUP} = 'IGNORE';
 827   local $SIG{INT} = 'IGNORE';
 828   local $SIG{QUIT} = 'IGNORE';
 829   local $SIG{TERM} = 'IGNORE';
 830   local $SIG{TSTP} = 'IGNORE';
 831   local $SIG{PIPE} = 'IGNORE';
 832
 833   #first cancel old packages
 834   foreach my $pkgnum ( @{$remove_pkgnums} ) {
 835     my($old) = qsearchs('cust_pkg',{'pkgnum'=>$pkgnum});
 836     unless ( $old ) {
 837       $dbh->rollback if $oldAutoCommit;
 838       return "Package $pkgnum not found to remove!";
 839     }
 840     my(%hash) = $old->hash;
 841     $hash{'cancel'}=time;
 842     my($new) = new FS::cust_pkg ( \%hash );
 843     my($error)=$new->replace($old);
 844     if ( $error ) {
 845       $dbh->rollback if $oldAutoCommit;
 846       return "Couldn't update package $pkgnum: $error";
 847     }
 848   }
 849
 850   #now add new packages, changing cust_svc records if necessary
 851   my $pkgpart;
 852   while ($pkgpart=shift @{$pkgparts} ) {
 853
 854     my $new = new FS::cust_pkg {
 855                                  'custnum' => $custnum,
 856                                  'pkgpart' => $pkgpart,
 857                                };
 858     my $error = $new->insert;
 859     if ( $error ) {
 860       $dbh->rollback if $oldAutoCommit;
 861       return "Couldn't insert new cust_pkg record: $error";
 862     }
 863     push @{$return_cust_pkg}, $new if $return_cust_pkg;
 864     my $pkgnum = $new->pkgnum;
 865
 866     foreach my $cust_svc ( @{ shift @cust_svc } ) {
 867       my(%hash) = $cust_svc->hash;
 868       $hash{'pkgnum'}=$pkgnum;
 869       my $new = new FS::cust_svc ( \%hash );
 870
 871       #avoid Record diffing missing changed svcpart field from above.
 872       my $old = qsearchs('cust_svc', { 'svcnum' => $cust_svc->svcnum } );
 873
 874       my $error = $new->replace($old);
 875       if ( $error ) {
 876         $dbh->rollback if $oldAutoCommit;
 877         return "Couldn't link old service to new package: $error";
 878       }
 879     }
 880   }
 881
 882   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 883
 884   ''; #no errors
 885 }
 886
 887 =back
 888
 889 =head1 BUGS
 890
 891 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
 892
 893 In sub order, the @pkgparts array (passed by reference) is clobbered.
 894
 895 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
 896 method to pass dates to the recur_prog expression, it should do so.
 897
 898 FS::svc_acct, FS::svc_acct_sm, and FS::svc_domain are loaded via 'use' at
 899 compile time, rather than via 'require' in sub { setup, suspend, unsuspend,
 900 cancel } because they use %FS::UID::callback to load configuration values.
 901 Probably need a subroutine which decides what to do based on whether or not
 902 we've fetched the user yet, rather than a hash.  See FS::UID and the TODO.
 903
 904 Now that things are transactional should the check in the insert method be
 905 moved to check ?
 906
 907 =head1 SEE ALSO
 908
 909 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
 910 L<FS::pkg_svc>, schema.html from the base documentation
 911
 912 =cut
 913
 914 1;
 915