FS/FS/cust_pkg.pm

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