FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2
   3 use strict;
   4 use base qw( FS::cust_main_Mixin FS::location_Mixin
   5              FS::m2m_Common FS::option_Common FS::Record
   6            );
   7 use vars qw(@ISA $disable_agentcheck $DEBUG $me);
   8 use Carp qw(cluck);
   9 use Scalar::Util qw( blessed );
  10 use List::Util qw(max);
  11 use Tie::IxHash;
  12 use Time::Local qw( timelocal_nocheck );
  13 use MIME::Entity;
  14 use FS::UID qw( getotaker dbh );
  15 use FS::Misc qw( send_email );
  16 use FS::Record qw( qsearch qsearchs );
  17 use FS::cust_svc;
  18 use FS::part_pkg;
  19 use FS::cust_main;
  20 use FS::cust_location;
  21 use FS::pkg_svc;
  22 use FS::cust_bill_pkg;
  23 use FS::cust_pkg_detail;
  24 use FS::cust_event;
  25 use FS::h_cust_svc;
  26 use FS::reg_code;
  27 use FS::part_svc;
  28 use FS::cust_pkg_reason;
  29 use FS::reason;
  30 use FS::UI::Web;
  31
  32 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  33 # setup }
  34 # because they load configuration by setting FS::UID::callback (see TODO)
  35 use FS::svc_acct;
  36 use FS::svc_domain;
  37 use FS::svc_www;
  38 use FS::svc_forward;
  39
  40 # for sending cancel emails in sub cancel
  41 use FS::Conf;
  42
  43 $DEBUG = 0;
  44 $me = '[FS::cust_pkg]';
  45
  46 $disable_agentcheck = 0;
  47
  48 sub _cache {
  49   my $self = shift;
  50   my ( $hashref, $cache ) = @_;
  51   #if ( $hashref->{'pkgpart'} ) {
  52   if ( $hashref->{'pkg'} ) {
  53     # #@{ $self->{'_pkgnum'} } = ();
  54     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  55     # $self->{'_pkgpart'} = $subcache;
  56     # #push @{ $self->{'_pkgnum'} },
  57     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  58     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  59   }
  60   if ( exists $hashref->{'svcnum'} ) {
  61     #@{ $self->{'_pkgnum'} } = ();
  62     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  63     $self->{'_svcnum'} = $subcache;
  64     #push @{ $self->{'_pkgnum'} },
  65     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  66   }
  67 }
  68
  69 =head1 NAME
  70
  71 FS::cust_pkg - Object methods for cust_pkg objects
  72
  73 =head1 SYNOPSIS
  74
  75   use FS::cust_pkg;
  76
  77   $record = new FS::cust_pkg \%hash;
  78   $record = new FS::cust_pkg { 'column' => 'value' };
  79
  80   $error = $record->insert;
  81
  82   $error = $new_record->replace($old_record);
  83
  84   $error = $record->delete;
  85
  86   $error = $record->check;
  87
  88   $error = $record->cancel;
  89
  90   $error = $record->suspend;
  91
  92   $error = $record->unsuspend;
  93
  94   $part_pkg = $record->part_pkg;
  95
  96   @labels = $record->labels;
  97
  98   $seconds = $record->seconds_since($timestamp);
  99
 100   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
 101   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
 102
 103 =head1 DESCRIPTION
 104
 105 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
 106 inherits from FS::Record.  The following fields are currently supported:
 107
 108 =over 4
 109
 110 =item pkgnum
 111
 112 Primary key (assigned automatically for new billing items)
 113
 114 =item custnum
 115
 116 Customer (see L<FS::cust_main>)
 117
 118 =item pkgpart
 119
 120 Billing item definition (see L<FS::part_pkg>)
 121
 122 =item locationnum
 123
 124 Optional link to package location (see L<FS::location>)
 125
 126 =item start_date
 127
 128 date
 129
 130 =item setup
 131
 132 date
 133
 134 =item bill
 135
 136 date (next bill date)
 137
 138 =item last_bill
 139
 140 last bill date
 141
 142 =item adjourn
 143
 144 date
 145
 146 =item susp
 147
 148 date
 149
 150 =item expire
 151
 152 date
 153
 154 =item cancel
 155
 156 date
 157
 158 =item otaker
 159
 160 order taker (assigned automatically if null, see L<FS::UID>)
 161
 162 =item manual_flag
 163
 164 If this field is set to 1, disables the automatic
 165 unsuspension of this package when using the B<unsuspendauto> config option.
 166
 167 =item quantity
 168
 169 If not set, defaults to 1
 170
 171 =item change_date
 172
 173 Date of change from previous package
 174
 175 =item change_pkgnum
 176
 177 Previous pkgnum
 178
 179 =item change_pkgpart
 180
 181 Previous pkgpart
 182
 183 =item change_locationnum
 184
 185 Previous locationnum
 186
 187 =back
 188
 189 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
 190 are specified as UNIX timestamps; see L<perlfunc/"time">.  Also see
 191 L<Time::Local> and L<Date::Parse> for conversion functions.
 192
 193 =head1 METHODS
 194
 195 =over 4
 196
 197 =item new HASHREF
 198
 199 Create a new billing item.  To add the item to the database, see L<"insert">.
 200
 201 =cut
 202
 203 sub table { 'cust_pkg'; }
 204 sub cust_linked { $_[0]->cust_main_custnum; }
 205 sub cust_unlinked_msg {
 206   my $self = shift;
 207   "WARNING: can't find cust_main.custnum ". $self->custnum.
 208   ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
 209 }
 210
 211 =item insert [ OPTION => VALUE ... ]
 212
 213 Adds this billing item to the database ("Orders" the item).  If there is an
 214 error, returns the error, otherwise returns false.
 215
 216 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
 217 will be used to look up the package definition and agent restrictions will be
 218 ignored.
 219
 220 If the additional field I<refnum> is defined, an FS::pkg_referral record will
 221 be created and inserted.  Multiple FS::pkg_referral records can be created by
 222 setting I<refnum> to an array reference of refnums or a hash reference with
 223 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
 224 record will be created corresponding to cust_main.refnum.
 225
 226 The following options are available:
 227
 228 =over 4
 229
 230 =item change
 231
 232 If set true, supresses any referral credit to a referring customer.
 233
 234 =item options
 235
 236 cust_pkg_option records will be created
 237
 238 =item ticket_subject
 239
 240 a ticket will be added to this customer with this subject
 241
 242 =item ticket_queue
 243
 244 an optional queue name for ticket additions
 245
 246 =back
 247
 248 =cut
 249
 250 sub insert {
 251   my( $self, %options ) = @_;
 252
 253   if ( $self->part_pkg->option('start_1st', 1) && !$self->start_date ) {
 254     my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
 255     $mon += 1 unless $mday == 1;
 256     until ( $mon < 12 ) { $mon -= 12; $year++; }
 257     $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
 258   }
 259
 260   my $expire_months = $self->part_pkg->option('expire_months', 1);
 261   if ( $expire_months && !$self->expire ) {
 262     my $start = $self->start_date || $self->setup || time;
 263
 264     #false laziness w/part_pkg::add_freq
 265     my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($start) )[0,1,2,3,4,5];
 266     $mon += $expire_months;
 267     until ( $mon < 12 ) { $mon -= 12; $year++; }
 268
 269     #$self->expire( timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year) );
 270     $self->expire( timelocal_nocheck(0,0,0,$mday,$mon,$year) );
 271   }
 272
 273   local $SIG{HUP} = 'IGNORE';
 274   local $SIG{INT} = 'IGNORE';
 275   local $SIG{QUIT} = 'IGNORE';
 276   local $SIG{TERM} = 'IGNORE';
 277   local $SIG{TSTP} = 'IGNORE';
 278   local $SIG{PIPE} = 'IGNORE';
 279
 280   my $oldAutoCommit = $FS::UID::AutoCommit;
 281   local $FS::UID::AutoCommit = 0;
 282   my $dbh = dbh;
 283
 284   my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
 285   if ( $error ) {
 286     $dbh->rollback if $oldAutoCommit;
 287     return $error;
 288   }
 289
 290   $self->refnum($self->cust_main->refnum) unless $self->refnum;
 291   $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
 292   $self->process_m2m( 'link_table'   => 'pkg_referral',
 293                       'target_table' => 'part_referral',
 294                       'params'       => $self->refnum,
 295                     );
 296
 297   #if ( $self->reg_code ) {
 298   #  my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
 299   #  $error = $reg_code->delete;
 300   #  if ( $error ) {
 301   #    $dbh->rollback if $oldAutoCommit;
 302   #    return $error;
 303   #  }
 304   #}
 305
 306   my $conf = new FS::Conf;
 307
 308   if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
 309     eval '
 310       use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
 311       use RT;
 312     ';
 313     die $@ if $@;
 314
 315     RT::LoadConfig();
 316     RT::Init();
 317     my $q = new RT::Queue($RT::SystemUser);
 318     $q->Load($options{ticket_queue}) if $options{ticket_queue};
 319     my $t = new RT::Ticket($RT::SystemUser);
 320     my $mime = new MIME::Entity;
 321     $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
 322     $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
 323                 Subject => $options{ticket_subject},
 324                 MIMEObj => $mime,
 325               );
 326     $t->AddLink( Type   => 'MemberOf',
 327                  Target => 'freeside://freeside/cust_main/'. $self->custnum,
 328                );
 329   }
 330
 331   if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
 332     my $queue = new FS::queue {
 333       'job'     => 'FS::cust_main::queueable_print',
 334     };
 335     $error = $queue->insert(
 336       'custnum'  => $self->custnum,
 337       'template' => 'welcome_letter',
 338     );
 339
 340     if ($error) {
 341       warn "can't send welcome letter: $error";
 342     }
 343
 344   }
 345
 346   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 347   '';
 348
 349 }
 350
 351 =item delete
 352
 353 This method now works but you probably shouldn't use it.
 354
 355 You don't want to delete billing items, because there would then be no record
 356 the customer ever purchased the item.  Instead, see the cancel method.
 357
 358 =cut
 359
 360 #sub delete {
 361 #  return "Can't delete cust_pkg records!";
 362 #}
 363
 364 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
 365
 366 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 367 returns the error, otherwise returns false.
 368
 369 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
 370
 371 Changing pkgpart may have disasterous effects.  See the order subroutine.
 372
 373 setup and bill are normally updated by calling the bill method of a customer
 374 object (see L<FS::cust_main>).
 375
 376 suspend is normally updated by the suspend and unsuspend methods.
 377
 378 cancel is normally updated by the cancel method (and also the order subroutine
 379 in some cases).
 380
 381 Available options are:
 382
 383 =over 4
 384
 385 =item reason
 386
 387 can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason.  The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
 388
 389 =item reason_otaker
 390
 391 the access_user (see L<FS::access_user>) providing the reason
 392
 393 =item options
 394
 395 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
 396
 397 =back
 398
 399 =cut
 400
 401 sub replace {
 402   my $new = shift;
 403
 404   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 405               ? shift
 406               : $new->replace_old;
 407
 408   my $options =
 409     ( ref($_[0]) eq 'HASH' )
 410       ? shift
 411       : { @_ };
 412
 413   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 414   return "Can't change otaker!" if $old->otaker ne $new->otaker;
 415
 416   #allow this *sigh*
 417   #return "Can't change setup once it exists!"
 418   #  if $old->getfield('setup') &&
 419   #     $old->getfield('setup') != $new->getfield('setup');
 420
 421   #some logic for bill, susp, cancel?
 422
 423   local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
 424
 425   local $SIG{HUP} = 'IGNORE';
 426   local $SIG{INT} = 'IGNORE';
 427   local $SIG{QUIT} = 'IGNORE';
 428   local $SIG{TERM} = 'IGNORE';
 429   local $SIG{TSTP} = 'IGNORE';
 430   local $SIG{PIPE} = 'IGNORE';
 431
 432   my $oldAutoCommit = $FS::UID::AutoCommit;
 433   local $FS::UID::AutoCommit = 0;
 434   my $dbh = dbh;
 435
 436   foreach my $method ( qw(adjourn expire) ) {  # How many reasons?
 437     if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
 438       my $error = $new->insert_reason(
 439         'reason'        => $options->{'reason'},
 440         'date'          => $new->$method,
 441         'action'        => $method,
 442         'reason_otaker' => $options->{'reason_otaker'},
 443       );
 444       if ( $error ) {
 445         dbh->rollback if $oldAutoCommit;
 446         return "Error inserting cust_pkg_reason: $error";
 447       }
 448     }
 449   }
 450
 451   #save off and freeze RADIUS attributes for any associated svc_acct records
 452   my @svc_acct = ();
 453   if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
 454
 455                 #also check for specific exports?
 456                 # to avoid spurious modify export events
 457     @svc_acct = map  { $_->svc_x }
 458                 grep { $_->part_svc->svcdb eq 'svc_acct' }
 459                      $old->cust_svc;
 460
 461     $_->snapshot foreach @svc_acct;
 462
 463   }
 464
 465   my $error = $new->SUPER::replace($old,
 466                                    $options->{options} ? $options->{options} : ()
 467                                   );
 468   if ( $error ) {
 469     $dbh->rollback if $oldAutoCommit;
 470     return $error;
 471   }
 472
 473   #for prepaid packages,
 474   #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
 475   foreach my $old_svc_acct ( @svc_acct ) {
 476     my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
 477     my $s_error = $new_svc_acct->replace($old_svc_acct);
 478     if ( $s_error ) {
 479       $dbh->rollback if $oldAutoCommit;
 480       return $s_error;
 481     }
 482   }
 483
 484   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 485   '';
 486
 487 }
 488
 489 =item check
 490
 491 Checks all fields to make sure this is a valid billing item.  If there is an
 492 error, returns the error, otherwise returns false.  Called by the insert and
 493 replace methods.
 494
 495 =cut
 496
 497 sub check {
 498   my $self = shift;
 499
 500   $self->locationnum('') if !$self->locationnum || $self->locationnum == -1;
 501
 502   my $error =
 503     $self->ut_numbern('pkgnum')
 504     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 505     || $self->ut_numbern('pkgpart')
 506     || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
 507     || $self->ut_numbern('start_date')
 508     || $self->ut_numbern('setup')
 509     || $self->ut_numbern('bill')
 510     || $self->ut_numbern('susp')
 511     || $self->ut_numbern('cancel')
 512     || $self->ut_numbern('adjourn')
 513     || $self->ut_numbern('expire')
 514   ;
 515   return $error if $error;
 516
 517   if ( $self->reg_code ) {
 518
 519     unless ( grep { $self->pkgpart == $_->pkgpart }
 520              map  { $_->reg_code_pkg }
 521              qsearchs( 'reg_code', { 'code'     => $self->reg_code,
 522                                      'agentnum' => $self->cust_main->agentnum })
 523            ) {
 524       return "Unknown registration code";
 525     }
 526
 527   } elsif ( $self->promo_code ) {
 528
 529     my $promo_part_pkg =
 530       qsearchs('part_pkg', {
 531         'pkgpart'    => $self->pkgpart,
 532         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 533       } );
 534     return 'Unknown promotional code' unless $promo_part_pkg;
 535
 536   } else {
 537
 538     unless ( $disable_agentcheck ) {
 539       my $agent =
 540         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 541       return "agent ". $agent->agentnum. ':'. $agent->agent.
 542              " can't purchase pkgpart ". $self->pkgpart
 543         unless $agent->pkgpart_hashref->{ $self->pkgpart }
 544             || $agent->agentnum == $self->part_pkg->agentnum;
 545     }
 546
 547     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 548     return $error if $error;
 549
 550   }
 551
 552   $self->otaker(getotaker) unless $self->otaker;
 553   $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker";
 554   $self->otaker($1);
 555
 556   if ( $self->dbdef_table->column('manual_flag') ) {
 557     $self->manual_flag('') if $self->manual_flag eq ' ';
 558     $self->manual_flag =~ /^([01]?)$/
 559       or return "Illegal manual_flag ". $self->manual_flag;
 560     $self->manual_flag($1);
 561   }
 562
 563   $self->SUPER::check;
 564 }
 565
 566 =item cancel [ OPTION => VALUE ... ]
 567
 568 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 569 in this package, then cancels the package itself (sets the cancel field to
 570 now).
 571
 572 Available options are:
 573
 574 =over 4
 575
 576 =item quiet - can be set true to supress email cancellation notices.
 577
 578 =item time -  can be set to cancel the package based on a specific future or historical date.  Using time ensures that the remaining amount is calculated correctly.  Note however that this is an immediate cancel and just changes the date.  You are PROBABLY looking to expire the account instead of using this.
 579
 580 =item reason - can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason.  The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
 581
 582 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
 583
 584 =item nobill - can be set true to skip billing if it might otherwise be done.
 585
 586 =back
 587
 588 If there is an error, returns the error, otherwise returns false.
 589
 590 =cut
 591
 592 sub cancel {
 593   my( $self, %options ) = @_;
 594   my $error;
 595
 596   my $conf = new FS::Conf;
 597
 598   warn "cust_pkg::cancel called with options".
 599        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 600     if $DEBUG;
 601
 602   local $SIG{HUP} = 'IGNORE';
 603   local $SIG{INT} = 'IGNORE';
 604   local $SIG{QUIT} = 'IGNORE';
 605   local $SIG{TERM} = 'IGNORE';
 606   local $SIG{TSTP} = 'IGNORE';
 607   local $SIG{PIPE} = 'IGNORE';
 608
 609   my $oldAutoCommit = $FS::UID::AutoCommit;
 610   local $FS::UID::AutoCommit = 0;
 611   my $dbh = dbh;
 612
 613   my $old = $self->select_for_update;
 614
 615   if ( $old->get('cancel') || $self->get('cancel') ) {
 616     dbh->rollback if $oldAutoCommit;
 617     return "";  # no error
 618   }
 619
 620   my $date = $options{date} if $options{date}; # expire/cancel later
 621   $date = '' if ($date && $date <= time);      # complain instead?
 622
 623   #race condition: usage could be ongoing until unprovisioned
 624   #resolved by performing a change package instead (which unprovisions) and
 625   #later cancelling
 626   if ( !$options{nobill} && !$date && $conf->exists('bill_usage_on_cancel') ) {
 627       my $copy = $self->new({$self->hash});
 628       my $error =
 629         $copy->cust_main->bill( pkg_list => [ $copy ], cancel => 1 );
 630       warn "Error billing during cancel, custnum ".
 631         #$self->cust_main->custnum. ": $error"
 632         ": $error"
 633         if $error;
 634   }
 635
 636
 637   my $cancel_time = $options{'time'} || time;
 638
 639   if ( $options{'reason'} ) {
 640     $error = $self->insert_reason( 'reason' => $options{'reason'},
 641                                    'action' => $date ? 'expire' : 'cancel',
 642                                    'date'   => $date ? $date : $cancel_time,
 643                                    'reason_otaker' => $options{'reason_otaker'},
 644                                  );
 645     if ( $error ) {
 646       dbh->rollback if $oldAutoCommit;
 647       return "Error inserting cust_pkg_reason: $error";
 648     }
 649   }
 650
 651   my %svc;
 652   unless ( $date ) {
 653     foreach my $cust_svc (
 654       #schwartz
 655       map  { $_->[0] }
 656       sort { $a->[1] <=> $b->[1] }
 657       map  { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
 658       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 659     ) {
 660
 661       my $error = $cust_svc->cancel;
 662
 663       if ( $error ) {
 664         $dbh->rollback if $oldAutoCommit;
 665         return "Error cancelling cust_svc: $error";
 666       }
 667     }
 668
 669     # Add a credit for remaining service
 670     my $remaining_value = $self->calc_remain(time=>$cancel_time);
 671     if ( $remaining_value > 0 && !$options{'no_credit'} ) {
 672       my $error = $self->cust_main->credit(
 673         $remaining_value,
 674         'Credit for unused time on '. $self->part_pkg->pkg,
 675         'reason_type' => $conf->config('cancel_credit_type'),
 676       );
 677       if ($error) {
 678         $dbh->rollback if $oldAutoCommit;
 679         return "Error crediting customer \$$remaining_value for unused time on".
 680                $self->part_pkg->pkg. ": $error";
 681       }
 682     }
 683   }
 684
 685   my %hash = $self->hash;
 686   $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
 687   my $new = new FS::cust_pkg ( \%hash );
 688   $error = $new->replace( $self, options => { $self->options } );
 689   if ( $error ) {
 690     $dbh->rollback if $oldAutoCommit;
 691     return $error;
 692   }
 693
 694   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 695   return '' if $date; #no errors
 696
 697   my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
 698   if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
 699     my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
 700     my $error = '';
 701     if ( $msgnum ) {
 702       my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
 703       $error = $msg_template->send( 'cust_main' => $self->cust_main,
 704                                     'object'    => $self );
 705     }
 706     else {
 707       $error = send_email(
 708         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 709         'to'      => \@invoicing_list,
 710         'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
 711         'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 712       );
 713     }
 714     #should this do something on errors?
 715   }
 716
 717   ''; #no errors
 718
 719 }
 720
 721 =item cancel_if_expired [ NOW_TIMESTAMP ]
 722
 723 Cancels this package if its expire date has been reached.
 724
 725 =cut
 726
 727 sub cancel_if_expired {
 728   my $self = shift;
 729   my $time = shift || time;
 730   return '' unless $self->expire && $self->expire <= $time;
 731   my $error = $self->cancel;
 732   if ( $error ) {
 733     return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
 734            $self->custnum. ": $error";
 735   }
 736   '';
 737 }
 738
 739 =item unexpire
 740
 741 Cancels any pending expiration (sets the expire field to null).
 742
 743 If there is an error, returns the error, otherwise returns false.
 744
 745 =cut
 746
 747 sub unexpire {
 748   my( $self, %options ) = @_;
 749   my $error;
 750
 751   local $SIG{HUP} = 'IGNORE';
 752   local $SIG{INT} = 'IGNORE';
 753   local $SIG{QUIT} = 'IGNORE';
 754   local $SIG{TERM} = 'IGNORE';
 755   local $SIG{TSTP} = 'IGNORE';
 756   local $SIG{PIPE} = 'IGNORE';
 757
 758   my $oldAutoCommit = $FS::UID::AutoCommit;
 759   local $FS::UID::AutoCommit = 0;
 760   my $dbh = dbh;
 761
 762   my $old = $self->select_for_update;
 763
 764   my $pkgnum = $old->pkgnum;
 765   if ( $old->get('cancel') || $self->get('cancel') ) {
 766     dbh->rollback if $oldAutoCommit;
 767     return "Can't unexpire cancelled package $pkgnum";
 768     # or at least it's pointless
 769   }
 770
 771   unless ( $old->get('expire') && $self->get('expire') ) {
 772     dbh->rollback if $oldAutoCommit;
 773     return "";  # no error
 774   }
 775
 776   my %hash = $self->hash;
 777   $hash{'expire'} = '';
 778   my $new = new FS::cust_pkg ( \%hash );
 779   $error = $new->replace( $self, options => { $self->options } );
 780   if ( $error ) {
 781     $dbh->rollback if $oldAutoCommit;
 782     return $error;
 783   }
 784
 785   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 786
 787   ''; #no errors
 788
 789 }
 790
 791 =item suspend [ OPTION => VALUE ... ]
 792
 793 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 794 package, then suspends the package itself (sets the susp field to now).
 795
 796 Available options are:
 797
 798 =over 4
 799
 800 =item reason - can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason.  The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
 801
 802 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
 803
 804 =back
 805
 806 If there is an error, returns the error, otherwise returns false.
 807
 808 =cut
 809
 810 sub suspend {
 811   my( $self, %options ) = @_;
 812   my $error;
 813
 814   local $SIG{HUP} = 'IGNORE';
 815   local $SIG{INT} = 'IGNORE';
 816   local $SIG{QUIT} = 'IGNORE';
 817   local $SIG{TERM} = 'IGNORE';
 818   local $SIG{TSTP} = 'IGNORE';
 819   local $SIG{PIPE} = 'IGNORE';
 820
 821   my $oldAutoCommit = $FS::UID::AutoCommit;
 822   local $FS::UID::AutoCommit = 0;
 823   my $dbh = dbh;
 824
 825   my $old = $self->select_for_update;
 826
 827   my $pkgnum = $old->pkgnum;
 828   if ( $old->get('cancel') || $self->get('cancel') ) {
 829     dbh->rollback if $oldAutoCommit;
 830     return "Can't suspend cancelled package $pkgnum";
 831   }
 832
 833   if ( $old->get('susp') || $self->get('susp') ) {
 834     dbh->rollback if $oldAutoCommit;
 835     return "";  # no error                     # complain on adjourn?
 836   }
 837
 838   my $date = $options{date} if $options{date}; # adjourn/suspend later
 839   $date = '' if ($date && $date <= time);      # complain instead?
 840
 841   if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
 842     dbh->rollback if $oldAutoCommit;
 843     return "Package $pkgnum expires before it would be suspended.";
 844   }
 845
 846   my $suspend_time = $options{'time'} || time;
 847
 848   if ( $options{'reason'} ) {
 849     $error = $self->insert_reason( 'reason' => $options{'reason'},
 850                                    'action' => $date ? 'adjourn' : 'suspend',
 851                                    'date'   => $date ? $date : $suspend_time,
 852                                    'reason_otaker' => $options{'reason_otaker'},
 853                                  );
 854     if ( $error ) {
 855       dbh->rollback if $oldAutoCommit;
 856       return "Error inserting cust_pkg_reason: $error";
 857     }
 858   }
 859
 860   unless ( $date ) {
 861
 862     my @labels = ();
 863
 864     foreach my $cust_svc (
 865       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 866     ) {
 867       my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 868
 869       $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 870         $dbh->rollback if $oldAutoCommit;
 871         return "Illegal svcdb value in part_svc!";
 872       };
 873       my $svcdb = $1;
 874       require "FS/$svcdb.pm";
 875
 876       my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 877       if ($svc) {
 878         $error = $svc->suspend;
 879         if ( $error ) {
 880           $dbh->rollback if $oldAutoCommit;
 881           return $error;
 882         }
 883         my( $label, $value ) = $cust_svc->label;
 884         push @labels, "$label: $value";
 885       }
 886     }
 887
 888     my $conf = new FS::Conf;
 889     if ( $conf->config('suspend_email_admin') ) {
 890
 891       my $error = send_email(
 892         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 893                                    #invoice_from ??? well as good as any
 894         'to'      => $conf->config('suspend_email_admin'),
 895         'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
 896         'body'    => [
 897           "This is an automatic message from your Freeside installation\n",
 898           "informing you that the following customer package has been suspended:\n",
 899           "\n",
 900           'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
 901           'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
 902           ( map { "Service : $_\n" } @labels ),
 903         ],
 904       );
 905
 906       if ( $error ) {
 907         warn "WARNING: can't send suspension admin email (suspending anyway): ".
 908              "$error\n";
 909       }
 910
 911     }
 912
 913   }
 914
 915   my %hash = $self->hash;
 916   if ( $date ) {
 917     $hash{'adjourn'} = $date;
 918   } else {
 919     $hash{'susp'} = $suspend_time;
 920   }
 921   my $new = new FS::cust_pkg ( \%hash );
 922   $error = $new->replace( $self, options => { $self->options } );
 923   if ( $error ) {
 924     $dbh->rollback if $oldAutoCommit;
 925     return $error;
 926   }
 927
 928   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 929
 930   ''; #no errors
 931 }
 932
 933 =item unsuspend [ OPTION => VALUE ... ]
 934
 935 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 936 package, then unsuspends the package itself (clears the susp field and the
 937 adjourn field if it is in the past).
 938
 939 Available options are:
 940
 941 =over 4
 942
 943 =item adjust_next_bill
 944
 945 Can be set true to adjust the next bill date forward by
 946 the amount of time the account was inactive.  This was set true by default
 947 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
 948 explicitly requested.  Price plans for which this makes sense (anniversary-date
 949 based than prorate or subscription) could have an option to enable this
 950 behaviour?
 951
 952 =back
 953
 954 If there is an error, returns the error, otherwise returns false.
 955
 956 =cut
 957
 958 sub unsuspend {
 959   my( $self, %opt ) = @_;
 960   my $error;
 961
 962   local $SIG{HUP} = 'IGNORE';
 963   local $SIG{INT} = 'IGNORE';
 964   local $SIG{QUIT} = 'IGNORE';
 965   local $SIG{TERM} = 'IGNORE';
 966   local $SIG{TSTP} = 'IGNORE';
 967   local $SIG{PIPE} = 'IGNORE';
 968
 969   my $oldAutoCommit = $FS::UID::AutoCommit;
 970   local $FS::UID::AutoCommit = 0;
 971   my $dbh = dbh;
 972
 973   my $old = $self->select_for_update;
 974
 975   my $pkgnum = $old->pkgnum;
 976   if ( $old->get('cancel') || $self->get('cancel') ) {
 977     dbh->rollback if $oldAutoCommit;
 978     return "Can't unsuspend cancelled package $pkgnum";
 979   }
 980
 981   unless ( $old->get('susp') && $self->get('susp') ) {
 982     dbh->rollback if $oldAutoCommit;
 983     return "";  # no error                     # complain instead?
 984   }
 985
 986   foreach my $cust_svc (
 987     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
 988   ) {
 989     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 990
 991     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 992       $dbh->rollback if $oldAutoCommit;
 993       return "Illegal svcdb value in part_svc!";
 994     };
 995     my $svcdb = $1;
 996     require "FS/$svcdb.pm";
 997
 998     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 999     if ($svc) {
1000       $error = $svc->unsuspend;
1001       if ( $error ) {
1002         $dbh->rollback if $oldAutoCommit;
1003         return $error;
1004       }
1005     }
1006
1007   }
1008
1009   my %hash = $self->hash;
1010   my $inactive = time - $hash{'susp'};
1011
1012   my $conf = new FS::Conf;
1013
1014   if ( $inactive > 0 &&
1015         ( $hash{'bill'} || $hash{'setup'} ) &&
1016         ( $opt{'adjust_next_bill'} ||
1017           $conf->exists('unsuspend-always_adjust_next_bill_date') ||
1018           $self->part_pkg->option('unsuspend_adjust_bill', 1) )
1019      ) {
1020
1021     $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
1022
1023   }
1024
1025   $hash{'susp'} = '';
1026   $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
1027   my $new = new FS::cust_pkg ( \%hash );
1028   $error = $new->replace( $self, options => { $self->options } );
1029   if ( $error ) {
1030     $dbh->rollback if $oldAutoCommit;
1031     return $error;
1032   }
1033
1034   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1035
1036   ''; #no errors
1037 }
1038
1039 =item unadjourn
1040
1041 Cancels any pending suspension (sets the adjourn field to null).
1042
1043 If there is an error, returns the error, otherwise returns false.
1044
1045 =cut
1046
1047 sub unadjourn {
1048   my( $self, %options ) = @_;
1049   my $error;
1050
1051   local $SIG{HUP} = 'IGNORE';
1052   local $SIG{INT} = 'IGNORE';
1053   local $SIG{QUIT} = 'IGNORE';
1054   local $SIG{TERM} = 'IGNORE';
1055   local $SIG{TSTP} = 'IGNORE';
1056   local $SIG{PIPE} = 'IGNORE';
1057
1058   my $oldAutoCommit = $FS::UID::AutoCommit;
1059   local $FS::UID::AutoCommit = 0;
1060   my $dbh = dbh;
1061
1062   my $old = $self->select_for_update;
1063
1064   my $pkgnum = $old->pkgnum;
1065   if ( $old->get('cancel') || $self->get('cancel') ) {
1066     dbh->rollback if $oldAutoCommit;
1067     return "Can't unadjourn cancelled package $pkgnum";
1068     # or at least it's pointless
1069   }
1070
1071   if ( $old->get('susp') || $self->get('susp') ) {
1072     dbh->rollback if $oldAutoCommit;
1073     return "Can't unadjourn suspended package $pkgnum";
1074     # perhaps this is arbitrary
1075   }
1076
1077   unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1078     dbh->rollback if $oldAutoCommit;
1079     return "";  # no error
1080   }
1081
1082   my %hash = $self->hash;
1083   $hash{'adjourn'} = '';
1084   my $new = new FS::cust_pkg ( \%hash );
1085   $error = $new->replace( $self, options => { $self->options } );
1086   if ( $error ) {
1087     $dbh->rollback if $oldAutoCommit;
1088     return $error;
1089   }
1090
1091   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1092
1093   ''; #no errors
1094
1095 }
1096
1097
1098 =item change HASHREF | OPTION => VALUE ...
1099
1100 Changes this package: cancels it and creates a new one, with a different
1101 pkgpart or locationnum or both.  All services are transferred to the new
1102 package (no change will be made if this is not possible).
1103
1104 Options may be passed as a list of key/value pairs or as a hash reference.
1105 Options are:
1106
1107 =over 4
1108
1109 =item locaitonnum
1110
1111 New locationnum, to change the location for this package.
1112
1113 =item cust_location
1114
1115 New FS::cust_location object, to create a new location and assign it
1116 to this package.
1117
1118 =item pkgpart
1119
1120 New pkgpart (see L<FS::part_pkg>).
1121
1122 =item refnum
1123
1124 New refnum (see L<FS::part_referral>).
1125
1126 =back
1127
1128 At least one option must be specified (otherwise, what's the point?)
1129
1130 Returns either the new FS::cust_pkg object or a scalar error.
1131
1132 For example:
1133
1134   my $err_or_new_cust_pkg = $old_cust_pkg->change
1135
1136 =cut
1137
1138 #some false laziness w/order
1139 sub change {
1140   my $self = shift;
1141   my $opt = ref($_[0]) ? shift : { @_ };
1142
1143 #  my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1144 #
1145
1146   my $conf = new FS::Conf;
1147
1148   # Transactionize this whole mess
1149   local $SIG{HUP} = 'IGNORE';
1150   local $SIG{INT} = 'IGNORE';
1151   local $SIG{QUIT} = 'IGNORE';
1152   local $SIG{TERM} = 'IGNORE';
1153   local $SIG{TSTP} = 'IGNORE';
1154   local $SIG{PIPE} = 'IGNORE';
1155
1156   my $oldAutoCommit = $FS::UID::AutoCommit;
1157   local $FS::UID::AutoCommit = 0;
1158   my $dbh = dbh;
1159
1160   my $error;
1161
1162   my %hash = ();
1163
1164   my $time = time;
1165
1166   #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1167
1168   #$hash{$_} = $self->$_() foreach qw( setup );
1169
1170   $hash{'setup'} = $time if $self->setup;
1171
1172   $hash{'change_date'} = $time;
1173   $hash{"change_$_"}  = $self->$_()
1174     foreach qw( pkgnum pkgpart locationnum );
1175
1176   if ( $opt->{'cust_location'} &&
1177        ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1178     $error = $opt->{'cust_location'}->insert;
1179     if ( $error ) {
1180       $dbh->rollback if $oldAutoCommit;
1181       return "inserting cust_location (transaction rolled back): $error";
1182     }
1183     $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1184   }
1185
1186   # Create the new package.
1187   my $cust_pkg = new FS::cust_pkg {
1188     custnum      => $self->custnum,
1189     pkgpart      => ( $opt->{'pkgpart'}     || $self->pkgpart      ),
1190     refnum       => ( $opt->{'refnum'}      || $self->refnum       ),
1191     locationnum  => ( $opt->{'locationnum'} || $self->locationnum  ),
1192     %hash,
1193   };
1194
1195   $error = $cust_pkg->insert( 'change' => 1 );
1196   if ($error) {
1197     $dbh->rollback if $oldAutoCommit;
1198     return $error;
1199   }
1200
1201   # Transfer services and cancel old package.
1202
1203   $error = $self->transfer($cust_pkg);
1204   if ($error and $error == 0) {
1205     # $old_pkg->transfer failed.
1206     $dbh->rollback if $oldAutoCommit;
1207     return $error;
1208   }
1209
1210   if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1211     warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1212     $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1213     if ($error and $error == 0) {
1214       # $old_pkg->transfer failed.
1215       $dbh->rollback if $oldAutoCommit;
1216       return $error;
1217     }
1218   }
1219
1220   if ($error > 0) {
1221     # Transfers were successful, but we still had services left on the old
1222     # package.  We can't change the package under this circumstances, so abort.
1223     $dbh->rollback if $oldAutoCommit;
1224     return "Unable to transfer all services from package ". $self->pkgnum;
1225   }
1226
1227   #reset usage if changing pkgpart
1228   # AND usage rollover is off (otherwise adds twice, now and at package bill)
1229   if ($self->pkgpart != $cust_pkg->pkgpart) {
1230     my $part_pkg = $cust_pkg->part_pkg;
1231     $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1232                                                  ? ()
1233                                                  : ( 'null' => 1 )
1234                                    )
1235       if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover');
1236
1237     if ($error) {
1238       $dbh->rollback if $oldAutoCommit;
1239       return "Error setting usage values: $error";
1240     }
1241   }
1242
1243   #Good to go, cancel old package.
1244   $error = $self->cancel( quiet=>1 );
1245   if ($error) {
1246     $dbh->rollback if $oldAutoCommit;
1247     return $error;
1248   }
1249
1250   if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1251     #$self->cust_main
1252     my $error = $cust_pkg->cust_main->bill( 'pkg_list' => [ $cust_pkg ] );
1253     if ( $error ) {
1254       $dbh->rollback if $oldAutoCommit;
1255       return $error;
1256     }
1257   }
1258
1259   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1260
1261   $cust_pkg;
1262
1263 }
1264
1265 =item last_bill
1266
1267 Returns the last bill date, or if there is no last bill date, the setup date.
1268 Useful for billing metered services.
1269
1270 =cut
1271
1272 sub last_bill {
1273   my $self = shift;
1274   return $self->setfield('last_bill', $_[0]) if @_;
1275   return $self->getfield('last_bill') if $self->getfield('last_bill');
1276   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1277                                                   'edate'  => $self->bill,  } );
1278   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1279 }
1280
1281 =item last_cust_pkg_reason ACTION
1282
1283 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1284 Returns false if there is no reason or the package is not currenly ACTION'd
1285 ACTION is one of adjourn, susp, cancel, or expire.
1286
1287 =cut
1288
1289 sub last_cust_pkg_reason {
1290   my ( $self, $action ) = ( shift, shift );
1291   my $date = $self->get($action);
1292   qsearchs( {
1293               'table' => 'cust_pkg_reason',
1294               'hashref' => { 'pkgnum' => $self->pkgnum,
1295                              'action' => substr(uc($action), 0, 1),
1296                              'date'   => $date,
1297                            },
1298               'order_by' => 'ORDER BY num DESC LIMIT 1',
1299            } );
1300 }
1301
1302 =item last_reason ACTION
1303
1304 Returns the most recent ACTION FS::reason associated with the package.
1305 Returns false if there is no reason or the package is not currenly ACTION'd
1306 ACTION is one of adjourn, susp, cancel, or expire.
1307
1308 =cut
1309
1310 sub last_reason {
1311   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1312   $cust_pkg_reason->reason
1313     if $cust_pkg_reason;
1314 }
1315
1316 =item part_pkg
1317
1318 Returns the definition for this billing item, as an FS::part_pkg object (see
1319 L<FS::part_pkg>).
1320
1321 =cut
1322
1323 sub part_pkg {
1324   my $self = shift;
1325   return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1326   cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1327   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1328 }
1329
1330 =item old_cust_pkg
1331
1332 Returns the cancelled package this package was changed from, if any.
1333
1334 =cut
1335
1336 sub old_cust_pkg {
1337   my $self = shift;
1338   return '' unless $self->change_pkgnum;
1339   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1340 }
1341
1342 =item calc_setup
1343
1344 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1345 item.
1346
1347 =cut
1348
1349 sub calc_setup {
1350   my $self = shift;
1351   $self->part_pkg->calc_setup($self, @_);
1352 }
1353
1354 =item calc_recur
1355
1356 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1357 item.
1358
1359 =cut
1360
1361 sub calc_recur {
1362   my $self = shift;
1363   $self->part_pkg->calc_recur($self, @_);
1364 }
1365
1366 =item calc_remain
1367
1368 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1369 billing item.
1370
1371 =cut
1372
1373 sub calc_remain {
1374   my $self = shift;
1375   $self->part_pkg->calc_remain($self, @_);
1376 }
1377
1378 =item calc_cancel
1379
1380 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1381 billing item.
1382
1383 =cut
1384
1385 sub calc_cancel {
1386   my $self = shift;
1387   $self->part_pkg->calc_cancel($self, @_);
1388 }
1389
1390 =item cust_bill_pkg
1391
1392 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1393
1394 =cut
1395
1396 sub cust_bill_pkg {
1397   my $self = shift;
1398   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1399 }
1400
1401 =item cust_pkg_detail [ DETAILTYPE ]
1402
1403 Returns any customer package details for this package (see
1404 L<FS::cust_pkg_detail>).
1405
1406 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1407
1408 =cut
1409
1410 sub cust_pkg_detail {
1411   my $self = shift;
1412   my %hash = ( 'pkgnum' => $self->pkgnum );
1413   $hash{detailtype} = shift if @_;
1414   qsearch({
1415     'table'    => 'cust_pkg_detail',
1416     'hashref'  => \%hash,
1417     'order_by' => 'ORDER BY weight, pkgdetailnum',
1418   });
1419 }
1420
1421 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1422
1423 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1424
1425 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1426
1427 If there is an error, returns the error, otherwise returns false.
1428
1429 =cut
1430
1431 sub set_cust_pkg_detail {
1432   my( $self, $detailtype, @details ) = @_;
1433
1434   local $SIG{HUP} = 'IGNORE';
1435   local $SIG{INT} = 'IGNORE';
1436   local $SIG{QUIT} = 'IGNORE';
1437   local $SIG{TERM} = 'IGNORE';
1438   local $SIG{TSTP} = 'IGNORE';
1439   local $SIG{PIPE} = 'IGNORE';
1440
1441   my $oldAutoCommit = $FS::UID::AutoCommit;
1442   local $FS::UID::AutoCommit = 0;
1443   my $dbh = dbh;
1444
1445   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1446     my $error = $current->delete;
1447     if ( $error ) {
1448       $dbh->rollback if $oldAutoCommit;
1449       return "error removing old detail: $error";
1450     }
1451   }
1452
1453   foreach my $detail ( @details ) {
1454     my $cust_pkg_detail = new FS::cust_pkg_detail {
1455       'pkgnum'     => $self->pkgnum,
1456       'detailtype' => $detailtype,
1457       'detail'     => $detail,
1458     };
1459     my $error = $cust_pkg_detail->insert;
1460     if ( $error ) {
1461       $dbh->rollback if $oldAutoCommit;
1462       return "error adding new detail: $error";
1463     }
1464
1465   }
1466
1467   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1468   '';
1469
1470 }
1471
1472 =item cust_event
1473
1474 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1475
1476 =cut
1477
1478 #false laziness w/cust_bill.pm
1479 sub cust_event {
1480   my $self = shift;
1481   qsearch({
1482     'table'     => 'cust_event',
1483     'addl_from' => 'JOIN part_event USING ( eventpart )',
1484     'hashref'   => { 'tablenum' => $self->pkgnum },
1485     'extra_sql' => " AND eventtable = 'cust_pkg' ",
1486   });
1487 }
1488
1489 =item num_cust_event
1490
1491 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1492
1493 =cut
1494
1495 #false laziness w/cust_bill.pm
1496 sub num_cust_event {
1497   my $self = shift;
1498   my $sql =
1499     "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1500     "  WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1501   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
1502   $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1503   $sth->fetchrow_arrayref->[0];
1504 }
1505
1506 =item cust_svc [ SVCPART ]
1507
1508 Returns the services for this package, as FS::cust_svc objects (see
1509 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
1510 services.
1511
1512 =cut
1513
1514 sub cust_svc {
1515   my $self = shift;
1516
1517   return () unless $self->num_cust_svc(@_);
1518
1519   if ( @_ ) {
1520     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
1521                                   'svcpart' => shift,          } );
1522   }
1523
1524   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1525
1526   #if ( $self->{'_svcnum'} ) {
1527   #  values %{ $self->{'_svcnum'}->cache };
1528   #} else {
1529     $self->_sort_cust_svc(
1530       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1531     );
1532   #}
1533
1534 }
1535
1536 =item overlimit [ SVCPART ]
1537
1538 Returns the services for this package which have exceeded their
1539 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
1540 is specified, return only the matching services.
1541
1542 =cut
1543
1544 sub overlimit {
1545   my $self = shift;
1546   return () unless $self->num_cust_svc(@_);
1547   grep { $_->overlimit } $self->cust_svc(@_);
1548 }
1549
1550 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1551
1552 Returns historical services for this package created before END TIMESTAMP and
1553 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1554 (see L<FS::h_cust_svc>).
1555
1556 =cut
1557
1558 sub h_cust_svc {
1559   my $self = shift;
1560
1561   $self->_sort_cust_svc(
1562     [ qsearch( 'h_cust_svc',
1563                { 'pkgnum' => $self->pkgnum, },
1564                FS::h_cust_svc->sql_h_search(@_),
1565              )
1566     ]
1567   );
1568 }
1569
1570 sub _sort_cust_svc {
1571   my( $self, $arrayref ) = @_;
1572
1573   my $sort =
1574     sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] };
1575
1576   map  { $_->[0] }
1577   sort $sort
1578   map {
1579         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1580                                              'svcpart' => $_->svcpart     } );
1581         [ $_,
1582           $pkg_svc ? $pkg_svc->primary_svc : '',
1583           $pkg_svc ? $pkg_svc->quantity : 0,
1584         ];
1585       }
1586   @$arrayref;
1587
1588 }
1589
1590 =item num_cust_svc [ SVCPART ]
1591
1592 Returns the number of provisioned services for this package.  If a svcpart is
1593 specified, counts only the matching services.
1594
1595 =cut
1596
1597 sub num_cust_svc {
1598   my $self = shift;
1599
1600   return $self->{'_num_cust_svc'}
1601     if !scalar(@_)
1602        && exists($self->{'_num_cust_svc'})
1603        && $self->{'_num_cust_svc'} =~ /\d/;
1604
1605   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1606     if $DEBUG > 2;
1607
1608   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1609   $sql .= ' AND svcpart = ?' if @_;
1610
1611   my $sth = dbh->prepare($sql)     or die  dbh->errstr;
1612   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1613   $sth->fetchrow_arrayref->[0];
1614 }
1615
1616 =item available_part_svc
1617
1618 Returns a list of FS::part_svc objects representing services included in this
1619 package but not yet provisioned.  Each FS::part_svc object also has an extra
1620 field, I<num_avail>, which specifies the number of available services.
1621
1622 =cut
1623
1624 sub available_part_svc {
1625   my $self = shift;
1626   grep { $_->num_avail > 0 }
1627     map {
1628           my $part_svc = $_->part_svc;
1629           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1630             $_->quantity - $self->num_cust_svc($_->svcpart);
1631           $part_svc;
1632         }
1633       $self->part_pkg->pkg_svc;
1634 }
1635
1636 =item part_svc
1637
1638 Returns a list of FS::part_svc objects representing provisioned and available
1639 services included in this package.  Each FS::part_svc object also has the
1640 following extra fields:
1641
1642 =over 4
1643
1644 =item num_cust_svc  (count)
1645
1646 =item num_avail     (quantity - count)
1647
1648 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1649
1650 svcnum
1651 label -> ($cust_svc->label)[1]
1652
1653 =back
1654
1655 =cut
1656
1657 sub part_svc {
1658   my $self = shift;
1659
1660   #XXX some sort of sort order besides numeric by svcpart...
1661   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1662     my $pkg_svc = $_;
1663     my $part_svc = $pkg_svc->part_svc;
1664     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1665     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1666     $part_svc->{'Hash'}{'num_avail'}    =
1667       max( 0, $pkg_svc->quantity - $num_cust_svc );
1668     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1669       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1670     $part_svc;
1671   } $self->part_pkg->pkg_svc;
1672
1673   #extras
1674   push @part_svc, map {
1675     my $part_svc = $_;
1676     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1677     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1678     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
1679     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1680       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1681     $part_svc;
1682   } $self->extra_part_svc;
1683
1684   @part_svc;
1685
1686 }
1687
1688 =item extra_part_svc
1689
1690 Returns a list of FS::part_svc objects corresponding to services in this
1691 package which are still provisioned but not (any longer) available in the
1692 package definition.
1693
1694 =cut
1695
1696 sub extra_part_svc {
1697   my $self = shift;
1698
1699   my $pkgnum  = $self->pkgnum;
1700   my $pkgpart = $self->pkgpart;
1701
1702 #  qsearch( {
1703 #    'table'     => 'part_svc',
1704 #    'hashref'   => {},
1705 #    'extra_sql' =>
1706 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1707 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
1708 #                       AND pkg_svc.pkgpart = ?
1709 #                       AND quantity > 0
1710 #                 )
1711 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
1712 #                       LEFT JOIN cust_pkg USING ( pkgnum )
1713 #                     WHERE cust_svc.svcpart = part_svc.svcpart
1714 #                       AND pkgnum = ?
1715 #                 )",
1716 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1717 #  } );
1718
1719 #seems to benchmark slightly faster...
1720   qsearch( {
1721     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
1722     #MySQL doesn't grok DISINCT ON
1723     'select'      => 'DISTINCT part_svc.*',
1724     'table'       => 'part_svc',
1725     'addl_from'   =>
1726       'LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
1727                                AND pkg_svc.pkgpart   = ?
1728                                AND quantity > 0
1729                              )
1730        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
1731        LEFT JOIN cust_pkg USING ( pkgnum )
1732       ',
1733     'hashref'     => {},
1734     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1735     'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1736   } );
1737 }
1738
1739 =item status
1740
1741 Returns a short status string for this package, currently:
1742
1743 =over 4
1744
1745 =item not yet billed
1746
1747 =item one-time charge
1748
1749 =item active
1750
1751 =item suspended
1752
1753 =item cancelled
1754
1755 =back
1756
1757 =cut
1758
1759 sub status {
1760   my $self = shift;
1761
1762   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1763
1764   return 'cancelled' if $self->get('cancel');
1765   return 'suspended' if $self->susp;
1766   return 'not yet billed' unless $self->setup;
1767   return 'one-time charge' if $freq =~ /^(0|$)/;
1768   return 'active';
1769 }
1770
1771 =item statuses
1772
1773 Class method that returns the list of possible status strings for packages
1774 (see L<the status method|/status>).  For example:
1775
1776   @statuses = FS::cust_pkg->statuses();
1777
1778 =cut
1779
1780 tie my %statuscolor, 'Tie::IxHash',
1781   'not yet billed'  => '000000',
1782   'one-time charge' => '000000',
1783   'active'          => '00CC00',
1784   'suspended'       => 'FF9900',
1785   'cancelled'       => 'FF0000',
1786 ;
1787
1788 sub statuses {
1789   my $self = shift; #could be class...
1790   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1791   #                                    # mayble split btw one-time vs. recur
1792     keys %statuscolor;
1793 }
1794
1795 =item statuscolor
1796
1797 Returns a hex triplet color string for this package's status.
1798
1799 =cut
1800
1801 sub statuscolor {
1802   my $self = shift;
1803   $statuscolor{$self->status};
1804 }
1805
1806 =item pkg_label
1807
1808 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
1809 "pkg-comment" depending on user preference).
1810
1811 =cut
1812
1813 sub pkg_label {
1814   my $self = shift;
1815   my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
1816   $label = $self->pkgnum. ": $label"
1817     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
1818   $label;
1819 }
1820
1821 =item pkg_label_long
1822
1823 Returns a long label for this package, adding the primary service's label to
1824 pkg_label.
1825
1826 =cut
1827
1828 sub pkg_label_long {
1829   my $self = shift;
1830   my $label = $self->pkg_label;
1831   my $cust_svc = $self->primary_cust_svc;
1832   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
1833   $label;
1834 }
1835
1836 =item primary_cust_svc
1837
1838 Returns a primary service (as FS::cust_svc object) if one can be identified.
1839
1840 =cut
1841
1842 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
1843
1844 sub primary_cust_svc {
1845   my $self = shift;
1846
1847   my @cust_svc = $self->cust_svc;
1848
1849   return '' unless @cust_svc; #no serivces - irrelevant then
1850
1851   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
1852
1853   # primary service as specified in the package definition
1854   # or exactly one service definition with quantity one
1855   my $svcpart = $self->part_pkg->svcpart;
1856   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
1857   return $cust_svc[0] if scalar(@cust_svc) == 1;
1858
1859   #couldn't identify one thing..
1860   return '';
1861 }
1862
1863 =item labels
1864
1865 Returns a list of lists, calling the label method for all services
1866 (see L<FS::cust_svc>) of this billing item.
1867
1868 =cut
1869
1870 sub labels {
1871   my $self = shift;
1872   map { [ $_->label ] } $self->cust_svc;
1873 }
1874
1875 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1876
1877 Like the labels method, but returns historical information on services that
1878 were active as of END_TIMESTAMP and (optionally) not cancelled before
1879 START_TIMESTAMP.
1880
1881 Returns a list of lists, calling the label method for all (historical) services
1882 (see L<FS::h_cust_svc>) of this billing item.
1883
1884 =cut
1885
1886 sub h_labels {
1887   my $self = shift;
1888   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1889 }
1890
1891 =item labels_short
1892
1893 Like labels, except returns a simple flat list, and shortens long
1894 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1895 identical services to one line that lists the service label and the number of
1896 individual services rather than individual items.
1897
1898 =cut
1899
1900 sub labels_short {
1901   shift->_labels_short( 'labels', @_ );
1902 }
1903
1904 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1905
1906 Like h_labels, except returns a simple flat list, and shortens long
1907 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1908 identical services to one line that lists the service label and the number of
1909 individual services rather than individual items.
1910
1911 =cut
1912
1913 sub h_labels_short {
1914   shift->_labels_short( 'h_labels', @_ );
1915 }
1916
1917 sub _labels_short {
1918   my( $self, $method ) = ( shift, shift );
1919
1920   my $conf = new FS::Conf;
1921   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
1922
1923   my %labels;
1924   #tie %labels, 'Tie::IxHash';
1925   push @{ $labels{$_->[0]} }, $_->[1]
1926     foreach $self->$method(@_);
1927   my @labels;
1928   foreach my $label ( keys %labels ) {
1929     my %seen = ();
1930     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
1931     my $num = scalar(@values);
1932     if ( $num > $max_same_services ) {
1933       push @labels, "$label ($num)";
1934     } else {
1935       if ( $conf->exists('cust_bill-consolidate_services') ) {
1936         # push @labels, "$label: ". join(', ', @values);
1937         while ( @values ) {
1938           my $detail = "$label: ";
1939           $detail .= shift(@values). ', '
1940             while @values && length($detail.$values[0]) < 78;
1941           $detail =~ s/, $//;
1942           push @labels, $detail;
1943         }
1944       } else {
1945         push @labels, map { "$label: $_" } @values;
1946       }
1947     }
1948   }
1949
1950  @labels;
1951
1952 }
1953
1954 =item cust_main
1955
1956 Returns the parent customer object (see L<FS::cust_main>).
1957
1958 =cut
1959
1960 sub cust_main {
1961   my $self = shift;
1962   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1963 }
1964
1965 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
1966
1967 =item cust_location
1968
1969 Returns the location object, if any (see L<FS::cust_location>).
1970
1971 =item cust_location_or_main
1972
1973 If this package is associated with a location, returns the locaiton (see
1974 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
1975
1976 =item location_label [ OPTION => VALUE ... ]
1977
1978 Returns the label of the location object (see L<FS::cust_location>).
1979
1980 =cut
1981
1982 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
1983
1984 =item seconds_since TIMESTAMP
1985
1986 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1987 package have been online since TIMESTAMP, according to the session monitor.
1988
1989 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1990 L<Time::Local> and L<Date::Parse> for conversion functions.
1991
1992 =cut
1993
1994 sub seconds_since {
1995   my($self, $since) = @_;
1996   my $seconds = 0;
1997
1998   foreach my $cust_svc (
1999     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2000   ) {
2001     $seconds += $cust_svc->seconds_since($since);
2002   }
2003
2004   $seconds;
2005
2006 }
2007
2008 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2009
2010 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2011 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2012 (exclusive).
2013
2014 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2015 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2016 functions.
2017
2018
2019 =cut
2020
2021 sub seconds_since_sqlradacct {
2022   my($self, $start, $end) = @_;
2023
2024   my $seconds = 0;
2025
2026   foreach my $cust_svc (
2027     grep {
2028       my $part_svc = $_->part_svc;
2029       $part_svc->svcdb eq 'svc_acct'
2030         && scalar($part_svc->part_export('sqlradius'));
2031     } $self->cust_svc
2032   ) {
2033     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2034   }
2035
2036   $seconds;
2037
2038 }
2039
2040 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2041
2042 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2043 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2044 TIMESTAMP_END
2045 (exclusive).
2046
2047 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2048 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2049 functions.
2050
2051 =cut
2052
2053 sub attribute_since_sqlradacct {
2054   my($self, $start, $end, $attrib) = @_;
2055
2056   my $sum = 0;
2057
2058   foreach my $cust_svc (
2059     grep {
2060       my $part_svc = $_->part_svc;
2061       $part_svc->svcdb eq 'svc_acct'
2062         && scalar($part_svc->part_export('sqlradius'));
2063     } $self->cust_svc
2064   ) {
2065     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2066   }
2067
2068   $sum;
2069
2070 }
2071
2072 =item quantity
2073
2074 =cut
2075
2076 sub quantity {
2077   my( $self, $value ) = @_;
2078   if ( defined($value) ) {
2079     $self->setfield('quantity', $value);
2080   }
2081   $self->getfield('quantity') || 1;
2082 }
2083
2084 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2085
2086 Transfers as many services as possible from this package to another package.
2087
2088 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2089 object.  The destination package must already exist.
2090
2091 Services are moved only if the destination allows services with the correct
2092 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
2093 this option with caution!  No provision is made for export differences
2094 between the old and new service definitions.  Probably only should be used
2095 when your exports for all service definitions of a given svcdb are identical.
2096 (attempt a transfer without it first, to move all possible svcpart-matching
2097 services)
2098
2099 Any services that can't be moved remain in the original package.
2100
2101 Returns an error, if there is one; otherwise, returns the number of services
2102 that couldn't be moved.
2103
2104 =cut
2105
2106 sub transfer {
2107   my ($self, $dest_pkgnum, %opt) = @_;
2108
2109   my $remaining = 0;
2110   my $dest;
2111   my %target;
2112
2113   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2114     $dest = $dest_pkgnum;
2115     $dest_pkgnum = $dest->pkgnum;
2116   } else {
2117     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2118   }
2119
2120   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2121
2122   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2123     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2124   }
2125
2126   foreach my $cust_svc ($dest->cust_svc) {
2127     $target{$cust_svc->svcpart}--;
2128   }
2129
2130   my %svcpart2svcparts = ();
2131   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2132     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2133     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2134       next if exists $svcpart2svcparts{$svcpart};
2135       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2136       $svcpart2svcparts{$svcpart} = [
2137         map  { $_->[0] }
2138         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
2139         map {
2140               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2141                                                    'svcpart' => $_          } );
2142               [ $_,
2143                 $pkg_svc ? $pkg_svc->primary_svc : '',
2144                 $pkg_svc ? $pkg_svc->quantity : 0,
2145               ];
2146             }
2147
2148         grep { $_ != $svcpart }
2149         map  { $_->svcpart }
2150         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2151       ];
2152       warn "alternates for svcpart $svcpart: ".
2153            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2154         if $DEBUG;
2155     }
2156   }
2157
2158   foreach my $cust_svc ($self->cust_svc) {
2159     if($target{$cust_svc->svcpart} > 0) {
2160       $target{$cust_svc->svcpart}--;
2161       my $new = new FS::cust_svc { $cust_svc->hash };
2162       $new->pkgnum($dest_pkgnum);
2163       my $error = $new->replace($cust_svc);
2164       return $error if $error;
2165     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2166       if ( $DEBUG ) {
2167         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2168         warn "alternates to consider: ".
2169              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2170       }
2171       my @alternate = grep {
2172                              warn "considering alternate svcpart $_: ".
2173                                   "$target{$_} available in new package\n"
2174                                if $DEBUG;
2175                              $target{$_} > 0;
2176                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
2177       if ( @alternate ) {
2178         warn "alternate(s) found\n" if $DEBUG;
2179         my $change_svcpart = $alternate[0];
2180         $target{$change_svcpart}--;
2181         my $new = new FS::cust_svc { $cust_svc->hash };
2182         $new->svcpart($change_svcpart);
2183         $new->pkgnum($dest_pkgnum);
2184         my $error = $new->replace($cust_svc);
2185         return $error if $error;
2186       } else {
2187         $remaining++;
2188       }
2189     } else {
2190       $remaining++
2191     }
2192   }
2193   return $remaining;
2194 }
2195
2196 =item reexport
2197
2198 This method is deprecated.  See the I<depend_jobnum> option to the insert and
2199 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2200
2201 =cut
2202
2203 sub reexport {
2204   my $self = shift;
2205
2206   local $SIG{HUP} = 'IGNORE';
2207   local $SIG{INT} = 'IGNORE';
2208   local $SIG{QUIT} = 'IGNORE';
2209   local $SIG{TERM} = 'IGNORE';
2210   local $SIG{TSTP} = 'IGNORE';
2211   local $SIG{PIPE} = 'IGNORE';
2212
2213   my $oldAutoCommit = $FS::UID::AutoCommit;
2214   local $FS::UID::AutoCommit = 0;
2215   my $dbh = dbh;
2216
2217   foreach my $cust_svc ( $self->cust_svc ) {
2218     #false laziness w/svc_Common::insert
2219     my $svc_x = $cust_svc->svc_x;
2220     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2221       my $error = $part_export->export_insert($svc_x);
2222       if ( $error ) {
2223         $dbh->rollback if $oldAutoCommit;
2224         return $error;
2225       }
2226     }
2227   }
2228
2229   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2230   '';
2231
2232 }
2233
2234 =back
2235
2236 =head1 CLASS METHODS
2237
2238 =over 4
2239
2240 =item recurring_sql
2241
2242 Returns an SQL expression identifying recurring packages.
2243
2244 =cut
2245
2246 sub recurring_sql { "
2247   '0' != ( select freq from part_pkg
2248              where cust_pkg.pkgpart = part_pkg.pkgpart )
2249 "; }
2250
2251 =item onetime_sql
2252
2253 Returns an SQL expression identifying one-time packages.
2254
2255 =cut
2256
2257 sub onetime_sql { "
2258   '0' = ( select freq from part_pkg
2259             where cust_pkg.pkgpart = part_pkg.pkgpart )
2260 "; }
2261
2262 =item active_sql
2263
2264 Returns an SQL expression identifying active packages.
2265
2266 =cut
2267
2268 sub active_sql { "
2269   ". $_[0]->recurring_sql(). "
2270   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2271   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2272   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2273 "; }
2274
2275 =item not_yet_billed_sql
2276
2277 Returns an SQL expression identifying packages which have not yet been billed.
2278
2279 =cut
2280
2281 sub not_yet_billed_sql { "
2282       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
2283   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2284   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2285 "; }
2286
2287 =item inactive_sql
2288
2289 Returns an SQL expression identifying inactive packages (one-time packages
2290 that are otherwise unsuspended/uncancelled).
2291
2292 =cut
2293
2294 sub inactive_sql { "
2295   ". $_[0]->onetime_sql(). "
2296   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2297   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2298   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2299 "; }
2300
2301 =item susp_sql
2302 =item suspended_sql
2303
2304 Returns an SQL expression identifying suspended packages.
2305
2306 =cut
2307
2308 sub suspended_sql { susp_sql(@_); }
2309 sub susp_sql {
2310   #$_[0]->recurring_sql(). ' AND '.
2311   "
2312         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
2313     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
2314   ";
2315 }
2316
2317 =item cancel_sql
2318 =item cancelled_sql
2319
2320 Returns an SQL exprression identifying cancelled packages.
2321
2322 =cut
2323
2324 sub cancelled_sql { cancel_sql(@_); }
2325 sub cancel_sql {
2326   #$_[0]->recurring_sql(). ' AND '.
2327   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2328 }
2329
2330 =item search HASHREF
2331
2332 (Class method)
2333
2334 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2335 Valid parameters are
2336
2337 =over 4
2338
2339 =item agentnum
2340
2341 =item magic
2342
2343 active, inactive, suspended, cancel (or cancelled)
2344
2345 =item status
2346
2347 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2348
2349 =item custom
2350
2351  boolean selects custom packages
2352
2353 =item classnum
2354
2355 =item pkgpart
2356
2357 pkgpart or arrayref or hashref of pkgparts
2358
2359 =item setup
2360
2361 arrayref of beginning and ending epoch date
2362
2363 =item last_bill
2364
2365 arrayref of beginning and ending epoch date
2366
2367 =item bill
2368
2369 arrayref of beginning and ending epoch date
2370
2371 =item adjourn
2372
2373 arrayref of beginning and ending epoch date
2374
2375 =item susp
2376
2377 arrayref of beginning and ending epoch date
2378
2379 =item expire
2380
2381 arrayref of beginning and ending epoch date
2382
2383 =item cancel
2384
2385 arrayref of beginning and ending epoch date
2386
2387 =item query
2388
2389 pkgnum or APKG_pkgnum
2390
2391 =item cust_fields
2392
2393 a value suited to passing to FS::UI::Web::cust_header
2394
2395 =item CurrentUser
2396
2397 specifies the user for agent virtualization
2398
2399 =item fcc_line
2400
2401  boolean selects packages containing fcc form 477 telco lines
2402
2403 =back
2404
2405 =cut
2406
2407 sub search {
2408   my ($class, $params) = @_;
2409   my @where = ();
2410
2411   ##
2412   # parse agent
2413   ##
2414
2415   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2416     push @where,
2417       "cust_main.agentnum = $1";
2418   }
2419
2420   ##
2421   # parse custnum
2422   ##
2423
2424   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2425     push @where,
2426       "cust_pkg.custnum = $1";
2427   }
2428
2429   ##
2430   # parse status
2431   ##
2432
2433   if (    $params->{'magic'}  eq 'active'
2434        || $params->{'status'} eq 'active' ) {
2435
2436     push @where, FS::cust_pkg->active_sql();
2437
2438   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
2439             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2440
2441     push @where, FS::cust_pkg->not_yet_billed_sql();
2442
2443   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
2444             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2445
2446     push @where, FS::cust_pkg->inactive_sql();
2447
2448   } elsif (    $params->{'magic'}  eq 'suspended'
2449             || $params->{'status'} eq 'suspended'  ) {
2450
2451     push @where, FS::cust_pkg->suspended_sql();
2452
2453   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
2454             || $params->{'status'} =~ /^cancell?ed$/ ) {
2455
2456     push @where, FS::cust_pkg->cancelled_sql();
2457
2458   }
2459
2460   ###
2461   # parse package class
2462   ###
2463
2464   #false lazinessish w/graph/cust_bill_pkg.cgi
2465   my $classnum = 0;
2466   my @pkg_class = ();
2467   if ( exists($params->{'classnum'})
2468        && $params->{'classnum'} =~ /^(\d*)$/
2469      )
2470   {
2471     $classnum = $1;
2472     if ( $classnum ) { #a specific class
2473       push @where, "part_pkg.classnum = $classnum";
2474
2475       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2476       #die "classnum $classnum not found!" unless $pkg_class[0];
2477       #$title .= $pkg_class[0]->classname.' ';
2478
2479     } elsif ( $classnum eq '' ) { #the empty class
2480
2481       push @where, "part_pkg.classnum IS NULL";
2482       #$title .= 'Empty class ';
2483       #@pkg_class = ( '(empty class)' );
2484     } elsif ( $classnum eq '0' ) {
2485       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2486       #push @pkg_class, '(empty class)';
2487     } else {
2488       die "illegal classnum";
2489     }
2490   }
2491   #eslaf
2492
2493   ###
2494   # parse package report options
2495   ###
2496
2497   my @report_option = ();
2498   if ( exists($params->{'report_option'})
2499        && $params->{'report_option'} =~ /^([,\d]*)$/
2500      )
2501   {
2502     @report_option = split(',', $1);
2503   }
2504
2505   if (@report_option) {
2506     # this will result in the empty set for the dangling comma case as it should
2507     push @where,
2508       map{ "0 < ( SELECT count(*) FROM part_pkg_option
2509                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2510                     AND optionname = 'report_option_$_'
2511                     AND optionvalue = '1' )"
2512          } @report_option;
2513   }
2514
2515   #eslaf
2516
2517   ###
2518   # parse custom
2519   ###
2520
2521   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
2522
2523   ###
2524   # parse fcc_line
2525   ###
2526
2527   push @where,  "part_pkg.fcc_ds0s > 0" if $params->{fcc_line};
2528
2529   ###
2530   # parse censustract
2531   ###
2532
2533   if ( exists($params->{'censustract'}) ) {
2534     $params->{'censustract'} =~ /^([.\d]*)$/;
2535     my $censustract = "cust_main.censustract = '$1'";
2536     $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2537     push @where,  "( $censustract )";
2538   }
2539
2540   ###
2541   # parse part_pkg
2542   ###
2543
2544   if ( ref($params->{'pkgpart'}) ) {
2545
2546     my @pkgpart = ();
2547     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
2548       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
2549     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
2550       @pkgpart = @{ $params->{'pkgpart'} };
2551     } else {
2552       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
2553     }
2554
2555     @pkgpart = grep /^(\d+)$/, @pkgpart;
2556
2557     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
2558
2559   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2560     push @where, "pkgpart = $1";
2561   }
2562
2563   ###
2564   # parse dates
2565   ###
2566
2567   my $orderby = '';
2568
2569   #false laziness w/report_cust_pkg.html
2570   my %disable = (
2571     'all'             => {},
2572     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2573     'active'          => { 'susp'=>1, 'cancel'=>1 },
2574     'suspended'       => { 'cancel' => 1 },
2575     'cancelled'       => {},
2576     ''                => {},
2577   );
2578
2579   if( exists($params->{'active'} ) ) {
2580     # This overrides all the other date-related fields
2581     my($beginning, $ending) = @{$params->{'active'}};
2582     push @where,
2583       "cust_pkg.setup IS NOT NULL",
2584       "cust_pkg.setup <= $ending",
2585       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
2586       "NOT (".FS::cust_pkg->onetime_sql . ")";
2587   }
2588   else {
2589     foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
2590
2591       next unless exists($params->{$field});
2592
2593       my($beginning, $ending) = @{$params->{$field}};
2594
2595       next if $beginning == 0 && $ending == 4294967295;
2596
2597       push @where,
2598         "cust_pkg.$field IS NOT NULL",
2599         "cust_pkg.$field >= $beginning",
2600         "cust_pkg.$field <= $ending";
2601
2602       $orderby ||= "ORDER BY cust_pkg.$field";
2603
2604     }
2605   }
2606
2607   $orderby ||= 'ORDER BY bill';
2608
2609   ###
2610   # parse magic, legacy, etc.
2611   ###
2612
2613   if ( $params->{'magic'} &&
2614        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2615   ) {
2616
2617     $orderby = 'ORDER BY pkgnum';
2618
2619     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2620       push @where, "pkgpart = $1";
2621     }
2622
2623   } elsif ( $params->{'query'} eq 'pkgnum' ) {
2624
2625     $orderby = 'ORDER BY pkgnum';
2626
2627   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2628
2629     $orderby = 'ORDER BY pkgnum';
2630
2631     push @where, '0 < (
2632       SELECT count(*) FROM pkg_svc
2633        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
2634          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2635                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
2636                                      AND cust_svc.svcpart = pkg_svc.svcpart
2637                                 )
2638     )';
2639
2640   }
2641
2642   ##
2643   # setup queries, links, subs, etc. for the search
2644   ##
2645
2646   # here is the agent virtualization
2647   if ($params->{CurrentUser}) {
2648     my $access_user =
2649       qsearchs('access_user', { username => $params->{CurrentUser} });
2650
2651     if ($access_user) {
2652       push @where, $access_user->agentnums_sql('table'=>'cust_main');
2653     } else {
2654       push @where, "1=0";
2655     }
2656   } else {
2657     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2658   }
2659
2660   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2661
2662   my $addl_from = 'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
2663                   'LEFT JOIN pkg_class USING ( classnum ) '.
2664                   'LEFT JOIN cust_main USING ( custnum  ) ';
2665
2666   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2667
2668   my $sql_query = {
2669     'table'       => 'cust_pkg',
2670     'hashref'     => {},
2671     'select'      => join(', ',
2672                                 'cust_pkg.*',
2673                                 ( map "part_pkg.$_", qw( pkg freq ) ),
2674                                 'pkg_class.classname',
2675                                 'cust_main.custnum as cust_main_custnum',
2676                                 FS::UI::Web::cust_sql_fields(
2677                                   $params->{'cust_fields'}
2678                                 ),
2679                      ),
2680     'extra_sql'   => "$extra_sql $orderby",
2681     'addl_from'   => $addl_from,
2682     'count_query' => $count_query,
2683   };
2684
2685 }
2686
2687 =item fcc_477_count
2688
2689 Returns a list of two package counts.  The first is a count of packages
2690 based on the supplied criteria and the second is the count of residential
2691 packages with those same criteria.  Criteria are specified as in the search
2692 method.
2693
2694 =cut
2695
2696 sub fcc_477_count {
2697   my ($class, $params) = @_;
2698
2699   my $sql_query = $class->search( $params );
2700
2701   my $count_sql = delete($sql_query->{'count_query'});
2702   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
2703     or die "couldn't parse count_sql";
2704
2705   my $count_sth = dbh->prepare($count_sql)
2706     or die "Error preparing $count_sql: ". dbh->errstr;
2707   $count_sth->execute
2708     or die "Error executing $count_sql: ". $count_sth->errstr;
2709   my $count_arrayref = $count_sth->fetchrow_arrayref;
2710
2711   return ( @$count_arrayref );
2712
2713 }
2714
2715
2716 =item location_sql
2717
2718 Returns a list: the first item is an SQL fragment identifying matching
2719 packages/customers via location (taking into account shipping and package
2720 address taxation, if enabled), and subsequent items are the parameters to
2721 substitute for the placeholders in that fragment.
2722
2723 =cut
2724
2725 sub location_sql {
2726   my($class, %opt) = @_;
2727   my $ornull = $opt{'ornull'};
2728
2729   my $conf = new FS::Conf;
2730
2731   # '?' placeholders in _location_sql_where
2732   my @bill_param;
2733   if ( $ornull ) {
2734     @bill_param = qw( county county state state state country );
2735   } else {
2736     @bill_param = qw( county state state country );
2737   }
2738   unshift @bill_param, 'county'; # unless $nec;
2739
2740   my $main_where;
2741   my @main_param;
2742   if ( $conf->exists('tax-ship_address') ) {
2743
2744     $main_where = "(
2745          (     ( ship_last IS NULL     OR  ship_last  = '' )
2746            AND ". _location_sql_where('cust_main', '', $ornull ). "
2747          )
2748       OR (       ship_last IS NOT NULL AND ship_last != ''
2749            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
2750          )
2751     )";
2752     #    AND payby != 'COMP'
2753
2754     @main_param = ( @bill_param, @bill_param );
2755
2756   } else {
2757
2758     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
2759     @main_param = @bill_param;
2760
2761   }
2762
2763   my $where;
2764   my @param;
2765   if ( $conf->exists('tax-pkg_address') ) {
2766
2767     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
2768
2769     $where = " (
2770                     ( cust_pkg.locationnum IS     NULL AND $main_where )
2771                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
2772                )
2773              ";
2774     @param = ( @main_param, @bill_param );
2775
2776   } else {
2777
2778     $where = $main_where;
2779     @param = @main_param;
2780
2781   }
2782
2783   ( $where, @param );
2784
2785 }
2786
2787 #subroutine, helper for location_sql
2788 sub _location_sql_where {
2789   my $table  = shift;
2790   my $prefix = @_ ? shift : '';
2791   my $ornull = @_ ? shift : '';
2792
2793 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
2794
2795   $ornull = $ornull ? ' OR ? IS NULL ' : '';
2796
2797   my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
2798   my $or_empty_state =  " OR ( ? = '' AND $table.${prefix}state  IS NULL ) ";
2799
2800   "
2801         ( $table.${prefix}county  = ? $or_empty_county $ornull )
2802     AND ( $table.${prefix}state   = ? $or_empty_state  $ornull )
2803     AND   $table.${prefix}country = ?
2804   ";
2805 }
2806
2807 =head1 SUBROUTINES
2808
2809 =over 4
2810
2811 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
2812
2813 CUSTNUM is a customer (see L<FS::cust_main>)
2814
2815 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2816 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
2817 permitted.
2818
2819 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
2820 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
2821 new billing items.  An error is returned if this is not possible (see
2822 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
2823 parameter.
2824
2825 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2826 newly-created cust_pkg objects.
2827
2828 REFNUM, if specified, will specify the FS::pkg_referral record to be created
2829 and inserted.  Multiple FS::pkg_referral records can be created by
2830 setting I<refnum> to an array reference of refnums or a hash reference with
2831 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
2832 record will be created corresponding to cust_main.refnum.
2833
2834 =cut
2835
2836 sub order {
2837   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
2838
2839   my $conf = new FS::Conf;
2840
2841   # Transactionize this whole mess
2842   local $SIG{HUP} = 'IGNORE';
2843   local $SIG{INT} = 'IGNORE';
2844   local $SIG{QUIT} = 'IGNORE';
2845   local $SIG{TERM} = 'IGNORE';
2846   local $SIG{TSTP} = 'IGNORE';
2847   local $SIG{PIPE} = 'IGNORE';
2848
2849   my $oldAutoCommit = $FS::UID::AutoCommit;
2850   local $FS::UID::AutoCommit = 0;
2851   my $dbh = dbh;
2852
2853   my $error;
2854 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
2855 #  return "Customer not found: $custnum" unless $cust_main;
2856
2857   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
2858     if $DEBUG;
2859
2860   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2861                          @$remove_pkgnum;
2862
2863   my $change = scalar(@old_cust_pkg) != 0;
2864
2865   my %hash = ();
2866   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
2867
2868     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
2869          " to pkgpart ". $pkgparts->[0]. "\n"
2870       if $DEBUG;
2871
2872     my $err_or_cust_pkg =
2873       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
2874                                 'refnum'  => $refnum,
2875                               );
2876
2877     unless (ref($err_or_cust_pkg)) {
2878       $dbh->rollback if $oldAutoCommit;
2879       return $err_or_cust_pkg;
2880     }
2881
2882     push @$return_cust_pkg, $err_or_cust_pkg;
2883     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2884     return '';
2885
2886   }
2887
2888   # Create the new packages.
2889   foreach my $pkgpart (@$pkgparts) {
2890
2891     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
2892
2893     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
2894                                       pkgpart => $pkgpart,
2895                                       refnum  => $refnum,
2896                                       %hash,
2897                                     };
2898     $error = $cust_pkg->insert( 'change' => $change );
2899     if ($error) {
2900       $dbh->rollback if $oldAutoCommit;
2901       return $error;
2902     }
2903     push @$return_cust_pkg, $cust_pkg;
2904   }
2905   # $return_cust_pkg now contains refs to all of the newly
2906   # created packages.
2907
2908   # Transfer services and cancel old packages.
2909   foreach my $old_pkg (@old_cust_pkg) {
2910
2911     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
2912       if $DEBUG;
2913
2914     foreach my $new_pkg (@$return_cust_pkg) {
2915       $error = $old_pkg->transfer($new_pkg);
2916       if ($error and $error == 0) {
2917         # $old_pkg->transfer failed.
2918         $dbh->rollback if $oldAutoCommit;
2919         return $error;
2920       }
2921     }
2922
2923     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2924       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2925       foreach my $new_pkg (@$return_cust_pkg) {
2926         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
2927         if ($error and $error == 0) {
2928           # $old_pkg->transfer failed.
2929         $dbh->rollback if $oldAutoCommit;
2930         return $error;
2931         }
2932       }
2933     }
2934
2935     if ($error > 0) {
2936       # Transfers were successful, but we went through all of the
2937       # new packages and still had services left on the old package.
2938       # We can't cancel the package under the circumstances, so abort.
2939       $dbh->rollback if $oldAutoCommit;
2940       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
2941     }
2942     $error = $old_pkg->cancel( quiet=>1 );
2943     if ($error) {
2944       $dbh->rollback;
2945       return $error;
2946     }
2947   }
2948   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2949   '';
2950 }
2951
2952 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
2953
2954 A bulk change method to change packages for multiple customers.
2955
2956 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2957 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
2958 permitted.
2959
2960 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
2961 replace.  The services (see L<FS::cust_svc>) are moved to the
2962 new billing items.  An error is returned if this is not possible (see
2963 L<FS::pkg_svc>).
2964
2965 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2966 newly-created cust_pkg objects.
2967
2968 =cut
2969
2970 sub bulk_change {
2971   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
2972
2973   # Transactionize this whole mess
2974   local $SIG{HUP} = 'IGNORE';
2975   local $SIG{INT} = 'IGNORE';
2976   local $SIG{QUIT} = 'IGNORE';
2977   local $SIG{TERM} = 'IGNORE';
2978   local $SIG{TSTP} = 'IGNORE';
2979   local $SIG{PIPE} = 'IGNORE';
2980
2981   my $oldAutoCommit = $FS::UID::AutoCommit;
2982   local $FS::UID::AutoCommit = 0;
2983   my $dbh = dbh;
2984
2985   my @errors;
2986   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2987                          @$remove_pkgnum;
2988
2989   while(scalar(@old_cust_pkg)) {
2990     my @return = ();
2991     my $custnum = $old_cust_pkg[0]->custnum;
2992     my (@remove) = map { $_->pkgnum }
2993                    grep { $_->custnum == $custnum } @old_cust_pkg;
2994     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
2995
2996     my $error = order $custnum, $pkgparts, \@remove, \@return;
2997
2998     push @errors, $error
2999       if $error;
3000     push @$return_cust_pkg, @return;
3001   }
3002
3003   if (scalar(@errors)) {
3004     $dbh->rollback if $oldAutoCommit;
3005     return join(' / ', @errors);
3006   }
3007
3008   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3009   '';
3010 }
3011
3012 =item insert_reason
3013
3014 Associates this package with a (suspension or cancellation) reason (see
3015 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
3016 L<FS::reason>).
3017
3018 Available options are:
3019
3020 =over 4
3021
3022 =item reason
3023
3024 can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason.  The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
3025
3026 =item reason_otaker
3027
3028 the access_user (see L<FS::access_user>) providing the reason
3029
3030 =item date
3031
3032 a unix timestamp
3033
3034 =item action
3035
3036 the action (cancel, susp, adjourn, expire) associated with the reason
3037
3038 =back
3039
3040 If there is an error, returns the error, otherwise returns false.
3041
3042 =cut
3043
3044 sub insert_reason {
3045   my ($self, %options) = @_;
3046
3047   my $otaker = $options{reason_otaker} ||
3048                $FS::CurrentUser::CurrentUser->username;
3049
3050   my $reasonnum;
3051   if ( $options{'reason'} =~ /^(\d+)$/ ) {
3052
3053     $reasonnum = $1;
3054
3055   } elsif ( ref($options{'reason'}) ) {
3056
3057     return 'Enter a new reason (or select an existing one)'
3058       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3059
3060     my $reason = new FS::reason({
3061       'reason_type' => $options{'reason'}->{'typenum'},
3062       'reason'      => $options{'reason'}->{'reason'},
3063     });
3064     my $error = $reason->insert;
3065     return $error if $error;
3066
3067     $reasonnum = $reason->reasonnum;
3068
3069   } else {
3070     return "Unparsable reason: ". $options{'reason'};
3071   }
3072
3073   my $cust_pkg_reason =
3074     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
3075                               'reasonnum' => $reasonnum,
3076                               'otaker'    => $otaker,
3077                               'action'    => substr(uc($options{'action'}),0,1),
3078                               'date'      => $options{'date'}
3079                                                ? $options{'date'}
3080                                                : time,
3081                             });
3082
3083   $cust_pkg_reason->insert;
3084 }
3085
3086 =item set_usage USAGE_VALUE_HASHREF
3087
3088 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3089 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3090 upbytes, downbytes, and totalbytes are appropriate keys.
3091
3092 All svc_accts which are part of this package have their values reset.
3093
3094 =cut
3095
3096 sub set_usage {
3097   my ($self, $valueref, %opt) = @_;
3098
3099   foreach my $cust_svc ($self->cust_svc){
3100     my $svc_x = $cust_svc->svc_x;
3101     $svc_x->set_usage($valueref, %opt)
3102       if $svc_x->can("set_usage");
3103   }
3104 }
3105
3106 =item recharge USAGE_VALUE_HASHREF
3107
3108 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3109 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3110 upbytes, downbytes, and totalbytes are appropriate keys.
3111
3112 All svc_accts which are part of this package have their values incremented.
3113
3114 =cut
3115
3116 sub recharge {
3117   my ($self, $valueref) = @_;
3118
3119   foreach my $cust_svc ($self->cust_svc){
3120     my $svc_x = $cust_svc->svc_x;
3121     $svc_x->recharge($valueref)
3122       if $svc_x->can("recharge");
3123   }
3124 }
3125
3126 =back
3127
3128 =head1 BUGS
3129
3130 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
3131
3132 In sub order, the @pkgparts array (passed by reference) is clobbered.
3133
3134 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
3135 method to pass dates to the recur_prog expression, it should do so.
3136
3137 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3138 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3139 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3140 configuration values.  Probably need a subroutine which decides what to do
3141 based on whether or not we've fetched the user yet, rather than a hash.  See
3142 FS::UID and the TODO.
3143
3144 Now that things are transactional should the check in the insert method be
3145 moved to check ?
3146
3147 =head1 SEE ALSO
3148
3149 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3150 L<FS::pkg_svc>, schema.html from the base documentation
3151
3152 =cut
3153
3154 1;
3155