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