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... (or did?)
1960
1961   my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
1962   my $pkgparts = join(',', @pkgparts);
1963
1964   qsearch( {
1965     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
1966     #MySQL doesn't grok DISINCT ON
1967     'select'      => 'DISTINCT part_svc.*',
1968     'table'       => 'part_svc',
1969     'addl_from'   =>
1970       "LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
1971                                AND pkg_svc.pkgpart IN ($pkgparts)
1972                                AND quantity > 0
1973                              )
1974        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
1975        LEFT JOIN cust_pkg USING ( pkgnum )
1976       ",
1977     'hashref'     => {},
1978     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1979     'extra_param' => [ [$self->pkgnum=>'int'] ],
1980   } );
1981 }
1982
1983 =item status
1984
1985 Returns a short status string for this package, currently:
1986
1987 =over 4
1988
1989 =item not yet billed
1990
1991 =item one-time charge
1992
1993 =item active
1994
1995 =item suspended
1996
1997 =item cancelled
1998
1999 =back
2000
2001 =cut
2002
2003 sub status {
2004   my $self = shift;
2005
2006   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
2007
2008   return 'cancelled' if $self->get('cancel');
2009   return 'suspended' if $self->susp;
2010   return 'not yet billed' unless $self->setup;
2011   return 'one-time charge' if $freq =~ /^(0|$)/;
2012   return 'active';
2013 }
2014
2015 =item ucfirst_status
2016
2017 Returns the status with the first character capitalized.
2018
2019 =cut
2020
2021 sub ucfirst_status {
2022   ucfirst(shift->status);
2023 }
2024
2025 =item statuses
2026
2027 Class method that returns the list of possible status strings for packages
2028 (see L<the status method|/status>).  For example:
2029
2030   @statuses = FS::cust_pkg->statuses();
2031
2032 =cut
2033
2034 tie my %statuscolor, 'Tie::IxHash',
2035   'not yet billed'  => '009999', #teal? cyan?
2036   'one-time charge' => '000000',
2037   'active'          => '00CC00',
2038   'suspended'       => 'FF9900',
2039   'cancelled'       => 'FF0000',
2040 ;
2041
2042 sub statuses {
2043   my $self = shift; #could be class...
2044   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
2045   #                                    # mayble split btw one-time vs. recur
2046     keys %statuscolor;
2047 }
2048
2049 =item statuscolor
2050
2051 Returns a hex triplet color string for this package's status.
2052
2053 =cut
2054
2055 sub statuscolor {
2056   my $self = shift;
2057   $statuscolor{$self->status};
2058 }
2059
2060 =item pkg_label
2061
2062 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
2063 "pkg-comment" depending on user preference).
2064
2065 =cut
2066
2067 sub pkg_label {
2068   my $self = shift;
2069   my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
2070   $label = $self->pkgnum. ": $label"
2071     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
2072   $label;
2073 }
2074
2075 =item pkg_label_long
2076
2077 Returns a long label for this package, adding the primary service's label to
2078 pkg_label.
2079
2080 =cut
2081
2082 sub pkg_label_long {
2083   my $self = shift;
2084   my $label = $self->pkg_label;
2085   my $cust_svc = $self->primary_cust_svc;
2086   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
2087   $label;
2088 }
2089
2090 =item primary_cust_svc
2091
2092 Returns a primary service (as FS::cust_svc object) if one can be identified.
2093
2094 =cut
2095
2096 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
2097
2098 sub primary_cust_svc {
2099   my $self = shift;
2100
2101   my @cust_svc = $self->cust_svc;
2102
2103   return '' unless @cust_svc; #no serivces - irrelevant then
2104
2105   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
2106
2107   # primary service as specified in the package definition
2108   # or exactly one service definition with quantity one
2109   my $svcpart = $self->part_pkg->svcpart;
2110   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
2111   return $cust_svc[0] if scalar(@cust_svc) == 1;
2112
2113   #couldn't identify one thing..
2114   return '';
2115 }
2116
2117 =item labels
2118
2119 Returns a list of lists, calling the label method for all services
2120 (see L<FS::cust_svc>) of this billing item.
2121
2122 =cut
2123
2124 sub labels {
2125   my $self = shift;
2126   map { [ $_->label ] } $self->cust_svc;
2127 }
2128
2129 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2130
2131 Like the labels method, but returns historical information on services that
2132 were active as of END_TIMESTAMP and (optionally) not cancelled before
2133 START_TIMESTAMP.  If MODE is 'I' (for 'invoice'), services with the
2134 I<pkg_svc.hidden> flag will be omitted.
2135
2136 Returns a list of lists, calling the label method for all (historical) services
2137 (see L<FS::h_cust_svc>) of this billing item.
2138
2139 =cut
2140
2141 sub h_labels {
2142   my $self = shift;
2143   warn "$me _h_labels called on $self\n"
2144     if $DEBUG;
2145   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
2146 }
2147
2148 =item labels_short
2149
2150 Like labels, except returns a simple flat list, and shortens long
2151 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2152 identical services to one line that lists the service label and the number of
2153 individual services rather than individual items.
2154
2155 =cut
2156
2157 sub labels_short {
2158   shift->_labels_short( 'labels', @_ );
2159 }
2160
2161 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
2162
2163 Like h_labels, except returns a simple flat list, and shortens long
2164 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2165 identical services to one line that lists the service label and the number of
2166 individual services rather than individual items.
2167
2168 =cut
2169
2170 sub h_labels_short {
2171   shift->_labels_short( 'h_labels', @_ );
2172 }
2173
2174 sub _labels_short {
2175   my( $self, $method ) = ( shift, shift );
2176
2177   warn "$me _labels_short called on $self with $method method\n"
2178     if $DEBUG;
2179
2180   my $conf = new FS::Conf;
2181   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
2182
2183   warn "$me _labels_short populating \%labels\n"
2184     if $DEBUG;
2185
2186   my %labels;
2187   #tie %labels, 'Tie::IxHash';
2188   push @{ $labels{$_->[0]} }, $_->[1]
2189     foreach $self->$method(@_);
2190
2191   warn "$me _labels_short populating \@labels\n"
2192     if $DEBUG;
2193
2194   my @labels;
2195   foreach my $label ( keys %labels ) {
2196     my %seen = ();
2197     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
2198     my $num = scalar(@values);
2199     warn "$me _labels_short $num items for $label\n"
2200       if $DEBUG;
2201
2202     if ( $num > $max_same_services ) {
2203       warn "$me _labels_short   more than $max_same_services, so summarizing\n"
2204         if $DEBUG;
2205       push @labels, "$label ($num)";
2206     } else {
2207       if ( $conf->exists('cust_bill-consolidate_services') ) {
2208         warn "$me _labels_short   consolidating services\n"
2209           if $DEBUG;
2210         # push @labels, "$label: ". join(', ', @values);
2211         while ( @values ) {
2212           my $detail = "$label: ";
2213           $detail .= shift(@values). ', '
2214             while @values
2215                && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
2216           $detail =~ s/, $//;
2217           push @labels, $detail;
2218         }
2219         warn "$me _labels_short   done consolidating services\n"
2220           if $DEBUG;
2221       } else {
2222         warn "$me _labels_short   adding service data\n"
2223           if $DEBUG;
2224         push @labels, map { "$label: $_" } @values;
2225       }
2226     }
2227   }
2228
2229  @labels;
2230
2231 }
2232
2233 =item cust_main
2234
2235 Returns the parent customer object (see L<FS::cust_main>).
2236
2237 =cut
2238
2239 sub cust_main {
2240   my $self = shift;
2241   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
2242 }
2243
2244 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
2245
2246 =item cust_location
2247
2248 Returns the location object, if any (see L<FS::cust_location>).
2249
2250 =item cust_location_or_main
2251
2252 If this package is associated with a location, returns the locaiton (see
2253 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
2254
2255 =item location_label [ OPTION => VALUE ... ]
2256
2257 Returns the label of the location object (see L<FS::cust_location>).
2258
2259 =cut
2260
2261 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2262
2263 =item seconds_since TIMESTAMP
2264
2265 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2266 package have been online since TIMESTAMP, according to the session monitor.
2267
2268 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2269 L<Time::Local> and L<Date::Parse> for conversion functions.
2270
2271 =cut
2272
2273 sub seconds_since {
2274   my($self, $since) = @_;
2275   my $seconds = 0;
2276
2277   foreach my $cust_svc (
2278     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2279   ) {
2280     $seconds += $cust_svc->seconds_since($since);
2281   }
2282
2283   $seconds;
2284
2285 }
2286
2287 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2288
2289 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2290 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2291 (exclusive).
2292
2293 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2294 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2295 functions.
2296
2297
2298 =cut
2299
2300 sub seconds_since_sqlradacct {
2301   my($self, $start, $end) = @_;
2302
2303   my $seconds = 0;
2304
2305   foreach my $cust_svc (
2306     grep {
2307       my $part_svc = $_->part_svc;
2308       $part_svc->svcdb eq 'svc_acct'
2309         && scalar($part_svc->part_export('sqlradius'));
2310     } $self->cust_svc
2311   ) {
2312     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2313   }
2314
2315   $seconds;
2316
2317 }
2318
2319 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2320
2321 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2322 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2323 TIMESTAMP_END
2324 (exclusive).
2325
2326 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2327 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2328 functions.
2329
2330 =cut
2331
2332 sub attribute_since_sqlradacct {
2333   my($self, $start, $end, $attrib) = @_;
2334
2335   my $sum = 0;
2336
2337   foreach my $cust_svc (
2338     grep {
2339       my $part_svc = $_->part_svc;
2340       $part_svc->svcdb eq 'svc_acct'
2341         && scalar($part_svc->part_export('sqlradius'));
2342     } $self->cust_svc
2343   ) {
2344     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2345   }
2346
2347   $sum;
2348
2349 }
2350
2351 =item quantity
2352
2353 =cut
2354
2355 sub quantity {
2356   my( $self, $value ) = @_;
2357   if ( defined($value) ) {
2358     $self->setfield('quantity', $value);
2359   }
2360   $self->getfield('quantity') || 1;
2361 }
2362
2363 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2364
2365 Transfers as many services as possible from this package to another package.
2366
2367 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2368 object.  The destination package must already exist.
2369
2370 Services are moved only if the destination allows services with the correct
2371 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
2372 this option with caution!  No provision is made for export differences
2373 between the old and new service definitions.  Probably only should be used
2374 when your exports for all service definitions of a given svcdb are identical.
2375 (attempt a transfer without it first, to move all possible svcpart-matching
2376 services)
2377
2378 Any services that can't be moved remain in the original package.
2379
2380 Returns an error, if there is one; otherwise, returns the number of services
2381 that couldn't be moved.
2382
2383 =cut
2384
2385 sub transfer {
2386   my ($self, $dest_pkgnum, %opt) = @_;
2387
2388   my $remaining = 0;
2389   my $dest;
2390   my %target;
2391
2392   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2393     $dest = $dest_pkgnum;
2394     $dest_pkgnum = $dest->pkgnum;
2395   } else {
2396     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2397   }
2398
2399   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2400
2401   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2402     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2403   }
2404
2405   foreach my $cust_svc ($dest->cust_svc) {
2406     $target{$cust_svc->svcpart}--;
2407   }
2408
2409   my %svcpart2svcparts = ();
2410   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2411     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2412     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2413       next if exists $svcpart2svcparts{$svcpart};
2414       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2415       $svcpart2svcparts{$svcpart} = [
2416         map  { $_->[0] }
2417         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
2418         map {
2419               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2420                                                    'svcpart' => $_          } );
2421               [ $_,
2422                 $pkg_svc ? $pkg_svc->primary_svc : '',
2423                 $pkg_svc ? $pkg_svc->quantity : 0,
2424               ];
2425             }
2426
2427         grep { $_ != $svcpart }
2428         map  { $_->svcpart }
2429         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2430       ];
2431       warn "alternates for svcpart $svcpart: ".
2432            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2433         if $DEBUG;
2434     }
2435   }
2436
2437   foreach my $cust_svc ($self->cust_svc) {
2438     if($target{$cust_svc->svcpart} > 0) {
2439       $target{$cust_svc->svcpart}--;
2440       my $new = new FS::cust_svc { $cust_svc->hash };
2441       $new->pkgnum($dest_pkgnum);
2442       my $error = $new->replace($cust_svc);
2443       return $error if $error;
2444     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2445       if ( $DEBUG ) {
2446         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2447         warn "alternates to consider: ".
2448              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2449       }
2450       my @alternate = grep {
2451                              warn "considering alternate svcpart $_: ".
2452                                   "$target{$_} available in new package\n"
2453                                if $DEBUG;
2454                              $target{$_} > 0;
2455                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
2456       if ( @alternate ) {
2457         warn "alternate(s) found\n" if $DEBUG;
2458         my $change_svcpart = $alternate[0];
2459         $target{$change_svcpart}--;
2460         my $new = new FS::cust_svc { $cust_svc->hash };
2461         $new->svcpart($change_svcpart);
2462         $new->pkgnum($dest_pkgnum);
2463         my $error = $new->replace($cust_svc);
2464         return $error if $error;
2465       } else {
2466         $remaining++;
2467       }
2468     } else {
2469       $remaining++
2470     }
2471   }
2472   return $remaining;
2473 }
2474
2475 =item reexport
2476
2477 This method is deprecated.  See the I<depend_jobnum> option to the insert and
2478 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2479
2480 =cut
2481
2482 sub reexport {
2483   my $self = shift;
2484
2485   local $SIG{HUP} = 'IGNORE';
2486   local $SIG{INT} = 'IGNORE';
2487   local $SIG{QUIT} = 'IGNORE';
2488   local $SIG{TERM} = 'IGNORE';
2489   local $SIG{TSTP} = 'IGNORE';
2490   local $SIG{PIPE} = 'IGNORE';
2491
2492   my $oldAutoCommit = $FS::UID::AutoCommit;
2493   local $FS::UID::AutoCommit = 0;
2494   my $dbh = dbh;
2495
2496   foreach my $cust_svc ( $self->cust_svc ) {
2497     #false laziness w/svc_Common::insert
2498     my $svc_x = $cust_svc->svc_x;
2499     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2500       my $error = $part_export->export_insert($svc_x);
2501       if ( $error ) {
2502         $dbh->rollback if $oldAutoCommit;
2503         return $error;
2504       }
2505     }
2506   }
2507
2508   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2509   '';
2510
2511 }
2512
2513 =item insert_reason
2514
2515 Associates this package with a (suspension or cancellation) reason (see
2516 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2517 L<FS::reason>).
2518
2519 Available options are:
2520
2521 =over 4
2522
2523 =item reason
2524
2525 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.
2526
2527 =item reason_otaker
2528
2529 the access_user (see L<FS::access_user>) providing the reason
2530
2531 =item date
2532
2533 a unix timestamp
2534
2535 =item action
2536
2537 the action (cancel, susp, adjourn, expire) associated with the reason
2538
2539 =back
2540
2541 If there is an error, returns the error, otherwise returns false.
2542
2543 =cut
2544
2545 sub insert_reason {
2546   my ($self, %options) = @_;
2547
2548   my $otaker = $options{reason_otaker} ||
2549                $FS::CurrentUser::CurrentUser->username;
2550
2551   my $reasonnum;
2552   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2553
2554     $reasonnum = $1;
2555
2556   } elsif ( ref($options{'reason'}) ) {
2557
2558     return 'Enter a new reason (or select an existing one)'
2559       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2560
2561     my $reason = new FS::reason({
2562       'reason_type' => $options{'reason'}->{'typenum'},
2563       'reason'      => $options{'reason'}->{'reason'},
2564     });
2565     my $error = $reason->insert;
2566     return $error if $error;
2567
2568     $reasonnum = $reason->reasonnum;
2569
2570   } else {
2571     return "Unparsable reason: ". $options{'reason'};
2572   }
2573
2574   my $cust_pkg_reason =
2575     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2576                               'reasonnum' => $reasonnum,
2577                               'otaker'    => $otaker,
2578                               'action'    => substr(uc($options{'action'}),0,1),
2579                               'date'      => $options{'date'}
2580                                                ? $options{'date'}
2581                                                : time,
2582                             });
2583
2584   $cust_pkg_reason->insert;
2585 }
2586
2587 =item insert_discount
2588
2589 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
2590 inserting a new discount on the fly (see L<FS::discount>).
2591
2592 Available options are:
2593
2594 =over 4
2595
2596 =item discountnum
2597
2598 =back
2599
2600 If there is an error, returns the error, otherwise returns false.
2601
2602 =cut
2603
2604 sub insert_discount {
2605   #my ($self, %options) = @_;
2606   my $self = shift;
2607
2608   my $cust_pkg_discount = new FS::cust_pkg_discount {
2609     'pkgnum'      => $self->pkgnum,
2610     'discountnum' => $self->discountnum,
2611     'months_used' => 0,
2612     'end_date'    => '', #XXX
2613     #for the create a new discount case
2614     '_type'       => $self->discountnum__type,
2615     'amount'      => $self->discountnum_amount,
2616     'percent'     => $self->discountnum_percent,
2617     'months'      => $self->discountnum_months,
2618     'setup'      => $self->discountnum_setup,
2619     #'disabled'    => $self->discountnum_disabled,
2620   };
2621
2622   $cust_pkg_discount->insert;
2623 }
2624
2625 =item set_usage USAGE_VALUE_HASHREF
2626
2627 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2628 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2629 upbytes, downbytes, and totalbytes are appropriate keys.
2630
2631 All svc_accts which are part of this package have their values reset.
2632
2633 =cut
2634
2635 sub set_usage {
2636   my ($self, $valueref, %opt) = @_;
2637
2638   foreach my $cust_svc ($self->cust_svc){
2639     my $svc_x = $cust_svc->svc_x;
2640     $svc_x->set_usage($valueref, %opt)
2641       if $svc_x->can("set_usage");
2642   }
2643 }
2644
2645 =item recharge USAGE_VALUE_HASHREF
2646
2647 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2648 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2649 upbytes, downbytes, and totalbytes are appropriate keys.
2650
2651 All svc_accts which are part of this package have their values incremented.
2652
2653 =cut
2654
2655 sub recharge {
2656   my ($self, $valueref) = @_;
2657
2658   foreach my $cust_svc ($self->cust_svc){
2659     my $svc_x = $cust_svc->svc_x;
2660     $svc_x->recharge($valueref)
2661       if $svc_x->can("recharge");
2662   }
2663 }
2664
2665 =item cust_pkg_discount
2666
2667 =cut
2668
2669 sub cust_pkg_discount {
2670   my $self = shift;
2671   qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
2672 }
2673
2674 =item cust_pkg_discount_active
2675
2676 =cut
2677
2678 sub cust_pkg_discount_active {
2679   my $self = shift;
2680   grep { $_->status eq 'active' } $self->cust_pkg_discount;
2681 }
2682
2683 =back
2684
2685 =head1 CLASS METHODS
2686
2687 =over 4
2688
2689 =item recurring_sql
2690
2691 Returns an SQL expression identifying recurring packages.
2692
2693 =cut
2694
2695 sub recurring_sql { "
2696   '0' != ( select freq from part_pkg
2697              where cust_pkg.pkgpart = part_pkg.pkgpart )
2698 "; }
2699
2700 =item onetime_sql
2701
2702 Returns an SQL expression identifying one-time packages.
2703
2704 =cut
2705
2706 sub onetime_sql { "
2707   '0' = ( select freq from part_pkg
2708             where cust_pkg.pkgpart = part_pkg.pkgpart )
2709 "; }
2710
2711 =item ordered_sql
2712
2713 Returns an SQL expression identifying ordered packages (recurring packages not
2714 yet billed).
2715
2716 =cut
2717
2718 sub ordered_sql {
2719    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
2720 }
2721
2722 =item active_sql
2723
2724 Returns an SQL expression identifying active packages.
2725
2726 =cut
2727
2728 sub active_sql {
2729   $_[0]->recurring_sql. "
2730   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2731   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2732   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2733 "; }
2734
2735 =item not_yet_billed_sql
2736
2737 Returns an SQL expression identifying packages which have not yet been billed.
2738
2739 =cut
2740
2741 sub not_yet_billed_sql { "
2742       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
2743   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2744   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2745 "; }
2746
2747 =item inactive_sql
2748
2749 Returns an SQL expression identifying inactive packages (one-time packages
2750 that are otherwise unsuspended/uncancelled).
2751
2752 =cut
2753
2754 sub inactive_sql { "
2755   ". $_[0]->onetime_sql(). "
2756   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2757   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2758   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2759 "; }
2760
2761 =item susp_sql
2762 =item suspended_sql
2763
2764 Returns an SQL expression identifying suspended packages.
2765
2766 =cut
2767
2768 sub suspended_sql { susp_sql(@_); }
2769 sub susp_sql {
2770   #$_[0]->recurring_sql(). ' AND '.
2771   "
2772         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
2773     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
2774   ";
2775 }
2776
2777 =item cancel_sql
2778 =item cancelled_sql
2779
2780 Returns an SQL exprression identifying cancelled packages.
2781
2782 =cut
2783
2784 sub cancelled_sql { cancel_sql(@_); }
2785 sub cancel_sql {
2786   #$_[0]->recurring_sql(). ' AND '.
2787   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2788 }
2789
2790 =item status_sql
2791
2792 Returns an SQL expression to give the package status as a string.
2793
2794 =cut
2795
2796 sub status_sql {
2797 "CASE
2798   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
2799   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
2800   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
2801   WHEN ".onetime_sql()." THEN 'one-time charge'
2802   ELSE 'active'
2803 END"
2804 }
2805
2806 =item search HASHREF
2807
2808 (Class method)
2809
2810 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2811 Valid parameters are
2812
2813 =over 4
2814
2815 =item agentnum
2816
2817 =item magic
2818
2819 active, inactive, suspended, cancel (or cancelled)
2820
2821 =item status
2822
2823 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2824
2825 =item custom
2826
2827  boolean selects custom packages
2828
2829 =item classnum
2830
2831 =item pkgpart
2832
2833 pkgpart or arrayref or hashref of pkgparts
2834
2835 =item setup
2836
2837 arrayref of beginning and ending epoch date
2838
2839 =item last_bill
2840
2841 arrayref of beginning and ending epoch date
2842
2843 =item bill
2844
2845 arrayref of beginning and ending epoch date
2846
2847 =item adjourn
2848
2849 arrayref of beginning and ending epoch date
2850
2851 =item susp
2852
2853 arrayref of beginning and ending epoch date
2854
2855 =item expire
2856
2857 arrayref of beginning and ending epoch date
2858
2859 =item cancel
2860
2861 arrayref of beginning and ending epoch date
2862
2863 =item query
2864
2865 pkgnum or APKG_pkgnum
2866
2867 =item cust_fields
2868
2869 a value suited to passing to FS::UI::Web::cust_header
2870
2871 =item CurrentUser
2872
2873 specifies the user for agent virtualization
2874
2875 =item fcc_line
2876
2877  boolean selects packages containing fcc form 477 telco lines
2878
2879 =back
2880
2881 =cut
2882
2883 sub search {
2884   my ($class, $params) = @_;
2885   my @where = ();
2886
2887   ##
2888   # parse agent
2889   ##
2890
2891   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2892     push @where,
2893       "cust_main.agentnum = $1";
2894   }
2895
2896   ##
2897   # parse custnum
2898   ##
2899
2900   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2901     push @where,
2902       "cust_pkg.custnum = $1";
2903   }
2904
2905   ##
2906   # custbatch
2907   ##
2908
2909   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
2910     push @where,
2911       "cust_pkg.pkgbatch = '$1'";
2912   }
2913
2914   ##
2915   # parse status
2916   ##
2917
2918   if (    $params->{'magic'}  eq 'active'
2919        || $params->{'status'} eq 'active' ) {
2920
2921     push @where, FS::cust_pkg->active_sql();
2922
2923   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
2924             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2925
2926     push @where, FS::cust_pkg->not_yet_billed_sql();
2927
2928   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
2929             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2930
2931     push @where, FS::cust_pkg->inactive_sql();
2932
2933   } elsif (    $params->{'magic'}  eq 'suspended'
2934             || $params->{'status'} eq 'suspended'  ) {
2935
2936     push @where, FS::cust_pkg->suspended_sql();
2937
2938   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
2939             || $params->{'status'} =~ /^cancell?ed$/ ) {
2940
2941     push @where, FS::cust_pkg->cancelled_sql();
2942
2943   }
2944
2945   ###
2946   # parse package class
2947   ###
2948
2949   #false lazinessish w/graph/cust_bill_pkg.cgi
2950   my $classnum = 0;
2951   my @pkg_class = ();
2952   if ( exists($params->{'classnum'})
2953        && $params->{'classnum'} =~ /^(\d*)$/
2954      )
2955   {
2956     $classnum = $1;
2957     if ( $classnum ) { #a specific class
2958       push @where, "part_pkg.classnum = $classnum";
2959
2960       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2961       #die "classnum $classnum not found!" unless $pkg_class[0];
2962       #$title .= $pkg_class[0]->classname.' ';
2963
2964     } elsif ( $classnum eq '' ) { #the empty class
2965
2966       push @where, "part_pkg.classnum IS NULL";
2967       #$title .= 'Empty class ';
2968       #@pkg_class = ( '(empty class)' );
2969     } elsif ( $classnum eq '0' ) {
2970       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2971       #push @pkg_class, '(empty class)';
2972     } else {
2973       die "illegal classnum";
2974     }
2975   }
2976   #eslaf
2977
2978   ###
2979   # parse package report options
2980   ###
2981
2982   my @report_option = ();
2983   if ( exists($params->{'report_option'})
2984        && $params->{'report_option'} =~ /^([,\d]*)$/
2985      )
2986   {
2987     @report_option = split(',', $1);
2988   }
2989
2990   if (@report_option) {
2991     # this will result in the empty set for the dangling comma case as it should
2992     push @where,
2993       map{ "0 < ( SELECT count(*) FROM part_pkg_option
2994                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2995                     AND optionname = 'report_option_$_'
2996                     AND optionvalue = '1' )"
2997          } @report_option;
2998   }
2999
3000   #eslaf
3001
3002   ###
3003   # parse custom
3004   ###
3005
3006   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
3007
3008   ###
3009   # parse fcc_line
3010   ###
3011
3012   push @where,  "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
3013                                                         if $params->{fcc_line};
3014
3015   ###
3016   # parse censustract
3017   ###
3018
3019   if ( exists($params->{'censustract'}) ) {
3020     $params->{'censustract'} =~ /^([.\d]*)$/;
3021     my $censustract = "cust_main.censustract = '$1'";
3022     $censustract .= ' OR cust_main.censustract is NULL' unless $1;
3023     push @where,  "( $censustract )";
3024   }
3025
3026   ###
3027   # parse part_pkg
3028   ###
3029
3030   if ( ref($params->{'pkgpart'}) ) {
3031
3032     my @pkgpart = ();
3033     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
3034       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
3035     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
3036       @pkgpart = @{ $params->{'pkgpart'} };
3037     } else {
3038       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
3039     }
3040
3041     @pkgpart = grep /^(\d+)$/, @pkgpart;
3042
3043     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
3044
3045   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3046     push @where, "pkgpart = $1";
3047   }
3048
3049   ###
3050   # parse dates
3051   ###
3052
3053   my $orderby = '';
3054
3055   #false laziness w/report_cust_pkg.html
3056   my %disable = (
3057     'all'             => {},
3058     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
3059     'active'          => { 'susp'=>1, 'cancel'=>1 },
3060     'suspended'       => { 'cancel' => 1 },
3061     'cancelled'       => {},
3062     ''                => {},
3063   );
3064
3065   if( exists($params->{'active'} ) ) {
3066     # This overrides all the other date-related fields
3067     my($beginning, $ending) = @{$params->{'active'}};
3068     push @where,
3069       "cust_pkg.setup IS NOT NULL",
3070       "cust_pkg.setup <= $ending",
3071       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
3072       "NOT (".FS::cust_pkg->onetime_sql . ")";
3073   }
3074   else {
3075     foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end cancel )) {
3076
3077       next unless exists($params->{$field});
3078
3079       my($beginning, $ending) = @{$params->{$field}};
3080
3081       next if $beginning == 0 && $ending == 4294967295;
3082
3083       push @where,
3084         "cust_pkg.$field IS NOT NULL",
3085         "cust_pkg.$field >= $beginning",
3086         "cust_pkg.$field <= $ending";
3087
3088       $orderby ||= "ORDER BY cust_pkg.$field";
3089
3090     }
3091   }
3092
3093   $orderby ||= 'ORDER BY bill';
3094
3095   ###
3096   # parse magic, legacy, etc.
3097   ###
3098
3099   if ( $params->{'magic'} &&
3100        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
3101   ) {
3102
3103     $orderby = 'ORDER BY pkgnum';
3104
3105     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3106       push @where, "pkgpart = $1";
3107     }
3108
3109   } elsif ( $params->{'query'} eq 'pkgnum' ) {
3110
3111     $orderby = 'ORDER BY pkgnum';
3112
3113   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
3114
3115     $orderby = 'ORDER BY pkgnum';
3116
3117     push @where, '0 < (
3118       SELECT count(*) FROM pkg_svc
3119        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
3120          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
3121                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
3122                                      AND cust_svc.svcpart = pkg_svc.svcpart
3123                                 )
3124     )';
3125
3126   }
3127
3128   ##
3129   # setup queries, links, subs, etc. for the search
3130   ##
3131
3132   # here is the agent virtualization
3133   if ($params->{CurrentUser}) {
3134     my $access_user =
3135       qsearchs('access_user', { username => $params->{CurrentUser} });
3136
3137     if ($access_user) {
3138       push @where, $access_user->agentnums_sql('table'=>'cust_main');
3139     } else {
3140       push @where, "1=0";
3141     }
3142   } else {
3143     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
3144   }
3145
3146   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
3147
3148   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
3149                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
3150                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) ';
3151
3152   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
3153
3154   my $sql_query = {
3155     'table'       => 'cust_pkg',
3156     'hashref'     => {},
3157     'select'      => join(', ',
3158                                 'cust_pkg.*',
3159                                 ( map "part_pkg.$_", qw( pkg freq ) ),
3160                                 'pkg_class.classname',
3161                                 'cust_main.custnum AS cust_main_custnum',
3162                                 FS::UI::Web::cust_sql_fields(
3163                                   $params->{'cust_fields'}
3164                                 ),
3165                      ),
3166     'extra_sql'   => "$extra_sql $orderby",
3167     'addl_from'   => $addl_from,
3168     'count_query' => $count_query,
3169   };
3170
3171 }
3172
3173 =item fcc_477_count
3174
3175 Returns a list of two package counts.  The first is a count of packages
3176 based on the supplied criteria and the second is the count of residential
3177 packages with those same criteria.  Criteria are specified as in the search
3178 method.
3179
3180 =cut
3181
3182 sub fcc_477_count {
3183   my ($class, $params) = @_;
3184
3185   my $sql_query = $class->search( $params );
3186
3187   my $count_sql = delete($sql_query->{'count_query'});
3188   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
3189     or die "couldn't parse count_sql";
3190
3191   my $count_sth = dbh->prepare($count_sql)
3192     or die "Error preparing $count_sql: ". dbh->errstr;
3193   $count_sth->execute
3194     or die "Error executing $count_sql: ". $count_sth->errstr;
3195   my $count_arrayref = $count_sth->fetchrow_arrayref;
3196
3197   return ( @$count_arrayref );
3198
3199 }
3200
3201
3202 =item location_sql
3203
3204 Returns a list: the first item is an SQL fragment identifying matching
3205 packages/customers via location (taking into account shipping and package
3206 address taxation, if enabled), and subsequent items are the parameters to
3207 substitute for the placeholders in that fragment.
3208
3209 =cut
3210
3211 sub location_sql {
3212   my($class, %opt) = @_;
3213   my $ornull = $opt{'ornull'};
3214
3215   my $conf = new FS::Conf;
3216
3217   # '?' placeholders in _location_sql_where
3218   my $x = $ornull ? 3 : 2;
3219   my @bill_param = ( ('city')x3, ('county')x$x, ('state')x$x, 'country' );
3220
3221   my $main_where;
3222   my @main_param;
3223   if ( $conf->exists('tax-ship_address') ) {
3224
3225     $main_where = "(
3226          (     ( ship_last IS NULL     OR  ship_last  = '' )
3227            AND ". _location_sql_where('cust_main', '', $ornull ). "
3228          )
3229       OR (       ship_last IS NOT NULL AND ship_last != ''
3230            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
3231          )
3232     )";
3233     #    AND payby != 'COMP'
3234
3235     @main_param = ( @bill_param, @bill_param );
3236
3237   } else {
3238
3239     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
3240     @main_param = @bill_param;
3241
3242   }
3243
3244   my $where;
3245   my @param;
3246   if ( $conf->exists('tax-pkg_address') ) {
3247
3248     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
3249
3250     $where = " (
3251                     ( cust_pkg.locationnum IS     NULL AND $main_where )
3252                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
3253                )
3254              ";
3255     @param = ( @main_param, @bill_param );
3256
3257   } else {
3258
3259     $where = $main_where;
3260     @param = @main_param;
3261
3262   }
3263
3264   ( $where, @param );
3265
3266 }
3267
3268 #subroutine, helper for location_sql
3269 sub _location_sql_where {
3270   my $table  = shift;
3271   my $prefix = @_ ? shift : '';
3272   my $ornull = @_ ? shift : '';
3273
3274 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
3275
3276   $ornull = $ornull ? ' OR ? IS NULL ' : '';
3277
3278   my $or_empty_city   = " OR ( ? = '' AND $table.${prefix}city   IS NULL ) ";
3279   my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
3280   my $or_empty_state =  " OR ( ? = '' AND $table.${prefix}state  IS NULL ) ";
3281
3282 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
3283   "
3284         ( $table.${prefix}city    = ? OR ? = '' OR CAST(? AS text) IS NULL )
3285     AND ( $table.${prefix}county  = ? $or_empty_county $ornull )
3286     AND ( $table.${prefix}state   = ? $or_empty_state  $ornull )
3287     AND   $table.${prefix}country = ?
3288   ";
3289 }
3290
3291 sub _X_show_zero {
3292   my( $self, $what ) = @_;
3293
3294   my $what_show_zero = $what. '_show_zero';
3295   length($self->$what_show_zero())
3296     ? ($self->$what_show_zero() eq 'Y')
3297     : $self->part_pkg->$what_show_zero();
3298 }
3299
3300 =head1 SUBROUTINES
3301
3302 =over 4
3303
3304 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
3305
3306 CUSTNUM is a customer (see L<FS::cust_main>)
3307
3308 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3309 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
3310 permitted.
3311
3312 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
3313 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
3314 new billing items.  An error is returned if this is not possible (see
3315 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
3316 parameter.
3317
3318 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3319 newly-created cust_pkg objects.
3320
3321 REFNUM, if specified, will specify the FS::pkg_referral record to be created
3322 and inserted.  Multiple FS::pkg_referral records can be created by
3323 setting I<refnum> to an array reference of refnums or a hash reference with
3324 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
3325 record will be created corresponding to cust_main.refnum.
3326
3327 =cut
3328
3329 sub order {
3330   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
3331
3332   my $conf = new FS::Conf;
3333
3334   # Transactionize this whole mess
3335   local $SIG{HUP} = 'IGNORE';
3336   local $SIG{INT} = 'IGNORE';
3337   local $SIG{QUIT} = 'IGNORE';
3338   local $SIG{TERM} = 'IGNORE';
3339   local $SIG{TSTP} = 'IGNORE';
3340   local $SIG{PIPE} = 'IGNORE';
3341
3342   my $oldAutoCommit = $FS::UID::AutoCommit;
3343   local $FS::UID::AutoCommit = 0;
3344   my $dbh = dbh;
3345
3346   my $error;
3347 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
3348 #  return "Customer not found: $custnum" unless $cust_main;
3349
3350   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
3351     if $DEBUG;
3352
3353   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3354                          @$remove_pkgnum;
3355
3356   my $change = scalar(@old_cust_pkg) != 0;
3357
3358   my %hash = ();
3359   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
3360
3361     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
3362          " to pkgpart ". $pkgparts->[0]. "\n"
3363       if $DEBUG;
3364
3365     my $err_or_cust_pkg =
3366       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3367                                 'refnum'  => $refnum,
3368                               );
3369
3370     unless (ref($err_or_cust_pkg)) {
3371       $dbh->rollback if $oldAutoCommit;
3372       return $err_or_cust_pkg;
3373     }
3374
3375     push @$return_cust_pkg, $err_or_cust_pkg;
3376     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3377     return '';
3378
3379   }
3380
3381   # Create the new packages.
3382   foreach my $pkgpart (@$pkgparts) {
3383
3384     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3385
3386     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3387                                       pkgpart => $pkgpart,
3388                                       refnum  => $refnum,
3389                                       %hash,
3390                                     };
3391     $error = $cust_pkg->insert( 'change' => $change );
3392     if ($error) {
3393       $dbh->rollback if $oldAutoCommit;
3394       return $error;
3395     }
3396     push @$return_cust_pkg, $cust_pkg;
3397   }
3398   # $return_cust_pkg now contains refs to all of the newly
3399   # created packages.
3400
3401   # Transfer services and cancel old packages.
3402   foreach my $old_pkg (@old_cust_pkg) {
3403
3404     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3405       if $DEBUG;
3406
3407     foreach my $new_pkg (@$return_cust_pkg) {
3408       $error = $old_pkg->transfer($new_pkg);
3409       if ($error and $error == 0) {
3410         # $old_pkg->transfer failed.
3411         $dbh->rollback if $oldAutoCommit;
3412         return $error;
3413       }
3414     }
3415
3416     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3417       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3418       foreach my $new_pkg (@$return_cust_pkg) {
3419         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3420         if ($error and $error == 0) {
3421           # $old_pkg->transfer failed.
3422         $dbh->rollback if $oldAutoCommit;
3423         return $error;
3424         }
3425       }
3426     }
3427
3428     if ($error > 0) {
3429       # Transfers were successful, but we went through all of the
3430       # new packages and still had services left on the old package.
3431       # We can't cancel the package under the circumstances, so abort.
3432       $dbh->rollback if $oldAutoCommit;
3433       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3434     }
3435     $error = $old_pkg->cancel( quiet=>1 );
3436     if ($error) {
3437       $dbh->rollback;
3438       return $error;
3439     }
3440   }
3441   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3442   '';
3443 }
3444
3445 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3446
3447 A bulk change method to change packages for multiple customers.
3448
3449 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3450 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
3451 permitted.
3452
3453 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3454 replace.  The services (see L<FS::cust_svc>) are moved to the
3455 new billing items.  An error is returned if this is not possible (see
3456 L<FS::pkg_svc>).
3457
3458 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3459 newly-created cust_pkg objects.
3460
3461 =cut
3462
3463 sub bulk_change {
3464   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3465
3466   # Transactionize this whole mess
3467   local $SIG{HUP} = 'IGNORE';
3468   local $SIG{INT} = 'IGNORE';
3469   local $SIG{QUIT} = 'IGNORE';
3470   local $SIG{TERM} = 'IGNORE';
3471   local $SIG{TSTP} = 'IGNORE';
3472   local $SIG{PIPE} = 'IGNORE';
3473
3474   my $oldAutoCommit = $FS::UID::AutoCommit;
3475   local $FS::UID::AutoCommit = 0;
3476   my $dbh = dbh;
3477
3478   my @errors;
3479   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3480                          @$remove_pkgnum;
3481
3482   while(scalar(@old_cust_pkg)) {
3483     my @return = ();
3484     my $custnum = $old_cust_pkg[0]->custnum;
3485     my (@remove) = map { $_->pkgnum }
3486                    grep { $_->custnum == $custnum } @old_cust_pkg;
3487     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3488
3489     my $error = order $custnum, $pkgparts, \@remove, \@return;
3490
3491     push @errors, $error
3492       if $error;
3493     push @$return_cust_pkg, @return;
3494   }
3495
3496   if (scalar(@errors)) {
3497     $dbh->rollback if $oldAutoCommit;
3498     return join(' / ', @errors);
3499   }
3500
3501   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3502   '';
3503 }
3504
3505 # Used by FS::Upgrade to migrate to a new database.
3506 sub _upgrade_data {  # class method
3507   my ($class, %opts) = @_;
3508   $class->_upgrade_otaker(%opts);
3509   my @statements = (
3510     # RT#10139, bug resulting in contract_end being set when it shouldn't
3511   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
3512     # RT#10830, bad calculation of prorate date near end of year
3513     # the date range for bill is December 2009, and we move it forward
3514     # one year if it's before the previous bill date (which it should
3515     # never be)
3516   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
3517   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
3518   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
3519     # RT6628, add order_date to cust_pkg
3520     'update cust_pkg set order_date = (select history_date from h_cust_pkg
3521         where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
3522         history_action = \'insert\') where order_date is null',
3523   );
3524   foreach my $sql (@statements) {
3525     my $sth = dbh->prepare($sql);
3526     $sth->execute or die $sth->errstr;
3527   }
3528 }
3529
3530 =back
3531
3532 =head1 BUGS
3533
3534 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
3535
3536 In sub order, the @pkgparts array (passed by reference) is clobbered.
3537
3538 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
3539 method to pass dates to the recur_prog expression, it should do so.
3540
3541 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3542 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3543 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3544 configuration values.  Probably need a subroutine which decides what to do
3545 based on whether or not we've fetched the user yet, rather than a hash.  See
3546 FS::UID and the TODO.
3547
3548 Now that things are transactional should the check in the insert method be
3549 moved to check ?
3550
3551 =head1 SEE ALSO
3552
3553 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3554 L<FS::pkg_svc>, schema.html from the base documentation
3555
3556 =cut
3557
3558 1;
3559