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