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