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