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