FS/FS/cust_pkg.pm

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