FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2 use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::Sales_Mixin
   3              FS::contact_Mixin FS::location_Mixin
   4              FS::m2m_Common FS::option_Common );
   5
   6 use strict;
   7 use vars qw( $disable_agentcheck $DEBUG $me $upgrade );
   8 use Carp qw(cluck);
   9 use Scalar::Util qw( blessed );
  10 use List::Util qw(min max);
  11 use Tie::IxHash;
  12 use Time::Local qw( timelocal timelocal_nocheck );
  13 use MIME::Entity;
  14 use FS::UID qw( getotaker dbh driver_name );
  15 use FS::Misc qw( send_email );
  16 use FS::Record qw( qsearch qsearchs fields );
  17 use FS::CurrentUser;
  18 use FS::cust_svc;
  19 use FS::part_pkg;
  20 use FS::cust_main;
  21 use FS::contact;
  22 use FS::cust_location;
  23 use FS::pkg_svc;
  24 use FS::cust_bill_pkg;
  25 use FS::cust_pkg_detail;
  26 use FS::cust_pkg_usage;
  27 use FS::cdr_cust_pkg_usage;
  28 use FS::cust_event;
  29 use FS::h_cust_svc;
  30 use FS::reg_code;
  31 use FS::part_svc;
  32 use FS::cust_pkg_reason;
  33 use FS::reason;
  34 use FS::cust_pkg_discount;
  35 use FS::discount;
  36 use FS::UI::Web;
  37 use FS::sales;
  38 # for modify_charge
  39 use FS::cust_credit;
  40
  41 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  42 # setup }
  43 # because they load configuration by setting FS::UID::callback (see TODO)
  44 use FS::svc_acct;
  45 use FS::svc_domain;
  46 use FS::svc_www;
  47 use FS::svc_forward;
  48
  49 # for sending cancel emails in sub cancel
  50 use FS::Conf;
  51
  52 $DEBUG = 0;
  53 $me = '[FS::cust_pkg]';
  54
  55 $disable_agentcheck = 0;
  56
  57 $upgrade = 0; #go away after setup+start dates cleaned up for old customers
  58
  59 sub _cache {
  60   my $self = shift;
  61   my ( $hashref, $cache ) = @_;
  62   #if ( $hashref->{'pkgpart'} ) {
  63   if ( $hashref->{'pkg'} ) {
  64     # #@{ $self->{'_pkgnum'} } = ();
  65     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  66     # $self->{'_pkgpart'} = $subcache;
  67     # #push @{ $self->{'_pkgnum'} },
  68     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  69     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  70   }
  71   if ( exists $hashref->{'svcnum'} ) {
  72     #@{ $self->{'_pkgnum'} } = ();
  73     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  74     $self->{'_svcnum'} = $subcache;
  75     #push @{ $self->{'_pkgnum'} },
  76     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  77   }
  78 }
  79
  80 =head1 NAME
  81
  82 FS::cust_pkg - Object methods for cust_pkg objects
  83
  84 =head1 SYNOPSIS
  85
  86   use FS::cust_pkg;
  87
  88   $record = new FS::cust_pkg \%hash;
  89   $record = new FS::cust_pkg { 'column' => 'value' };
  90
  91   $error = $record->insert;
  92
  93   $error = $new_record->replace($old_record);
  94
  95   $error = $record->delete;
  96
  97   $error = $record->check;
  98
  99   $error = $record->cancel;
 100
 101   $error = $record->suspend;
 102
 103   $error = $record->unsuspend;
 104
 105   $part_pkg = $record->part_pkg;
 106
 107   @labels = $record->labels;
 108
 109   $seconds = $record->seconds_since($timestamp);
 110
 111   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
 112   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
 113
 114 =head1 DESCRIPTION
 115
 116 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
 117 inherits from FS::Record.  The following fields are currently supported:
 118
 119 =over 4
 120
 121 =item pkgnum
 122
 123 Primary key (assigned automatically for new billing items)
 124
 125 =item custnum
 126
 127 Customer (see L<FS::cust_main>)
 128
 129 =item pkgpart
 130
 131 Billing item definition (see L<FS::part_pkg>)
 132
 133 =item locationnum
 134
 135 Optional link to package location (see L<FS::location>)
 136
 137 =item order_date
 138
 139 date package was ordered (also remains same on changes)
 140
 141 =item start_date
 142
 143 date
 144
 145 =item setup
 146
 147 date
 148
 149 =item bill
 150
 151 date (next bill date)
 152
 153 =item last_bill
 154
 155 last bill date
 156
 157 =item adjourn
 158
 159 date
 160
 161 =item susp
 162
 163 date
 164
 165 =item expire
 166
 167 date
 168
 169 =item contract_end
 170
 171 date
 172
 173 =item cancel
 174
 175 date
 176
 177 =item usernum
 178
 179 order taker (see L<FS::access_user>)
 180
 181 =item manual_flag
 182
 183 If this field is set to 1, disables the automatic
 184 unsuspension of this package when using the B<unsuspendauto> config option.
 185
 186 =item quantity
 187
 188 If not set, defaults to 1
 189
 190 =item change_date
 191
 192 Date of change from previous package
 193
 194 =item change_pkgnum
 195
 196 Previous pkgnum
 197
 198 =item change_pkgpart
 199
 200 Previous pkgpart
 201
 202 =item change_locationnum
 203
 204 Previous locationnum
 205
 206 =item waive_setup
 207
 208 =item main_pkgnum
 209
 210 The pkgnum of the package that this package is supplemental to, if any.
 211
 212 =item pkglinknum
 213
 214 The package link (L<FS::part_pkg_link>) that defines this supplemental
 215 package, if it is one.
 216
 217 =item change_to_pkgnum
 218
 219 The pkgnum of the package this one will be "changed to" in the future
 220 (on its expiration date).
 221
 222 =back
 223
 224 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
 225 are specified as UNIX timestamps; see L<perlfunc/"time">.  Also see
 226 L<Time::Local> and L<Date::Parse> for conversion functions.
 227
 228 =head1 METHODS
 229
 230 =over 4
 231
 232 =item new HASHREF
 233
 234 Create a new billing item.  To add the item to the database, see L<"insert">.
 235
 236 =cut
 237
 238 sub table { 'cust_pkg'; }
 239 sub cust_linked { $_[0]->cust_main_custnum || $_[0]->custnum }
 240 sub cust_unlinked_msg {
 241   my $self = shift;
 242   "WARNING: can't find cust_main.custnum ". $self->custnum.
 243   ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
 244 }
 245
 246 =item insert [ OPTION => VALUE ... ]
 247
 248 Adds this billing item to the database ("Orders" the item).  If there is an
 249 error, returns the error, otherwise returns false.
 250
 251 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
 252 will be used to look up the package definition and agent restrictions will be
 253 ignored.
 254
 255 If the additional field I<refnum> is defined, an FS::pkg_referral record will
 256 be created and inserted.  Multiple FS::pkg_referral records can be created by
 257 setting I<refnum> to an array reference of refnums or a hash reference with
 258 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
 259 record will be created corresponding to cust_main.refnum.
 260
 261 The following options are available:
 262
 263 =over 4
 264
 265 =item change
 266
 267 If set true, supresses actions that should only be taken for new package
 268 orders.  (Currently this includes: intro periods when delay_setup is on,
 269 auto-adding a 1st start date, auto-adding expiration/adjourn/contract_end dates)
 270
 271 =item options
 272
 273 cust_pkg_option records will be created
 274
 275 =item ticket_subject
 276
 277 a ticket will be added to this customer with this subject
 278
 279 =item ticket_queue
 280
 281 an optional queue name for ticket additions
 282
 283 =item allow_pkgpart
 284
 285 Don't check the legality of the package definition.  This should be used
 286 when performing a package change that doesn't change the pkgpart (i.e.
 287 a location change).
 288
 289 =back
 290
 291 =cut
 292
 293 sub insert {
 294   my( $self, %options ) = @_;
 295
 296   my $error;
 297   $error = $self->check_pkgpart unless $options{'allow_pkgpart'};
 298   return $error if $error;
 299
 300   my $part_pkg = $self->part_pkg;
 301
 302   if ( ! $options{'change'} ) {
 303
 304     # if the package def says to start only on the first of the month:
 305     if ( $part_pkg->option('start_1st', 1) && !$self->start_date ) {
 306       my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
 307       $mon += 1 unless $mday == 1;
 308       until ( $mon < 12 ) { $mon -= 12; $year++; }
 309       $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
 310     }
 311
 312     # set up any automatic expire/adjourn/contract_end timers
 313     # based on the start date
 314     foreach my $action ( qw(expire adjourn contract_end) ) {
 315       my $months = $part_pkg->option("${action}_months",1);
 316       if($months and !$self->$action) {
 317         my $start = $self->start_date || $self->setup || time;
 318         $self->$action( $part_pkg->add_freq($start, $months) );
 319       }
 320     }
 321
 322     # if this package has "free days" and delayed setup fee, then
 323     # set start date that many days in the future.
 324     # (this should have been set in the UI, but enforce it here)
 325     if (    ! $options{'change'}
 326          && $part_pkg->option('free_days',1)
 327          && $part_pkg->option('delay_setup',1)
 328          #&& ! $self->start_date
 329        )
 330     {
 331       $self->start_date( $part_pkg->default_start_date );
 332     }
 333
 334   }
 335
 336   # set order date unless this was previously a different package
 337   $self->order_date(time) unless $self->change_pkgnum;
 338
 339   local $SIG{HUP} = 'IGNORE';
 340   local $SIG{INT} = 'IGNORE';
 341   local $SIG{QUIT} = 'IGNORE';
 342   local $SIG{TERM} = 'IGNORE';
 343   local $SIG{TSTP} = 'IGNORE';
 344   local $SIG{PIPE} = 'IGNORE';
 345
 346   $self->susp( $self->order_date ) if $self->susp eq 'now';
 347
 348   my $oldAutoCommit = $FS::UID::AutoCommit;
 349   local $FS::UID::AutoCommit = 0;
 350   my $dbh = dbh;
 351
 352   $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
 353   if ( $error ) {
 354     $dbh->rollback if $oldAutoCommit;
 355     return $error;
 356   }
 357
 358   $self->refnum($self->cust_main->refnum) unless $self->refnum;
 359   $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
 360   $self->process_m2m( 'link_table'   => 'pkg_referral',
 361                       'target_table' => 'part_referral',
 362                       'params'       => $self->refnum,
 363                     );
 364
 365   if ( $self->discountnum ) {
 366     my $error = $self->insert_discount();
 367     if ( $error ) {
 368       $dbh->rollback if $oldAutoCommit;
 369       return $error;
 370     }
 371   }
 372
 373   my $conf = new FS::Conf;
 374
 375   if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
 376
 377     #this init stuff is still inefficient, but at least its limited to
 378     # the small number (any?) folks using ticket emailing on pkg order
 379
 380     #eval '
 381     #  use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
 382     #  use RT;
 383     #';
 384     #die $@ if $@;
 385     #
 386     #RT::LoadConfig();
 387     #RT::Init();
 388     use FS::TicketSystem;
 389     FS::TicketSystem->init();
 390
 391     my $q = new RT::Queue($RT::SystemUser);
 392     $q->Load($options{ticket_queue}) if $options{ticket_queue};
 393     my $t = new RT::Ticket($RT::SystemUser);
 394     my $mime = new MIME::Entity;
 395     $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
 396     $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
 397                 Subject => $options{ticket_subject},
 398                 MIMEObj => $mime,
 399               );
 400     $t->AddLink( Type   => 'MemberOf',
 401                  Target => 'freeside://freeside/cust_main/'. $self->custnum,
 402                );
 403   }
 404
 405   if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
 406     my $queue = new FS::queue {
 407       'job'     => 'FS::cust_main::queueable_print',
 408     };
 409     $error = $queue->insert(
 410       'custnum'  => $self->custnum,
 411       'template' => 'welcome_letter',
 412     );
 413
 414     if ($error) {
 415       warn "can't send welcome letter: $error";
 416     }
 417
 418   }
 419
 420   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 421   '';
 422
 423 }
 424
 425 =item delete
 426
 427 This method now works but you probably shouldn't use it.
 428
 429 You don't want to delete packages, because there would then be no record
 430 the customer ever purchased the package.  Instead, see the cancel method and
 431 hide cancelled packages.
 432
 433 =cut
 434
 435 sub delete {
 436   my $self = shift;
 437
 438   local $SIG{HUP} = 'IGNORE';
 439   local $SIG{INT} = 'IGNORE';
 440   local $SIG{QUIT} = 'IGNORE';
 441   local $SIG{TERM} = 'IGNORE';
 442   local $SIG{TSTP} = 'IGNORE';
 443   local $SIG{PIPE} = 'IGNORE';
 444
 445   my $oldAutoCommit = $FS::UID::AutoCommit;
 446   local $FS::UID::AutoCommit = 0;
 447   my $dbh = dbh;
 448
 449   foreach my $cust_pkg_discount ($self->cust_pkg_discount) {
 450     my $error = $cust_pkg_discount->delete;
 451     if ( $error ) {
 452       $dbh->rollback if $oldAutoCommit;
 453       return $error;
 454     }
 455   }
 456   #cust_bill_pkg_discount?
 457
 458   foreach my $cust_pkg_detail ($self->cust_pkg_detail) {
 459     my $error = $cust_pkg_detail->delete;
 460     if ( $error ) {
 461       $dbh->rollback if $oldAutoCommit;
 462       return $error;
 463     }
 464   }
 465
 466   foreach my $cust_pkg_reason (
 467     qsearchs( {
 468                 'table' => 'cust_pkg_reason',
 469                 'hashref' => { 'pkgnum' => $self->pkgnum },
 470               }
 471             )
 472   ) {
 473     my $error = $cust_pkg_reason->delete;
 474     if ( $error ) {
 475       $dbh->rollback if $oldAutoCommit;
 476       return $error;
 477     }
 478   }
 479
 480   #pkg_referral?
 481
 482   my $error = $self->SUPER::delete(@_);
 483   if ( $error ) {
 484     $dbh->rollback if $oldAutoCommit;
 485     return $error;
 486   }
 487
 488   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 489
 490   '';
 491
 492 }
 493
 494 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
 495
 496 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 497 returns the error, otherwise returns false.
 498
 499 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
 500
 501 Changing pkgpart may have disasterous effects.  See the order subroutine.
 502
 503 setup and bill are normally updated by calling the bill method of a customer
 504 object (see L<FS::cust_main>).
 505
 506 suspend is normally updated by the suspend and unsuspend methods.
 507
 508 cancel is normally updated by the cancel method (and also the order subroutine
 509 in some cases).
 510
 511 Available options are:
 512
 513 =over 4
 514
 515 =item reason
 516
 517 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.
 518
 519 =item reason_otaker
 520
 521 the access_user (see L<FS::access_user>) providing the reason
 522
 523 =item options
 524
 525 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
 526
 527 =back
 528
 529 =cut
 530
 531 sub replace {
 532   my $new = shift;
 533
 534   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 535               ? shift
 536               : $new->replace_old;
 537
 538   my $options =
 539     ( ref($_[0]) eq 'HASH' )
 540       ? shift
 541       : { @_ };
 542
 543   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 544   #return "Can't change otaker!" if $old->otaker ne $new->otaker;
 545
 546   #allow this *sigh*
 547   #return "Can't change setup once it exists!"
 548   #  if $old->getfield('setup') &&
 549   #     $old->getfield('setup') != $new->getfield('setup');
 550
 551   #some logic for bill, susp, cancel?
 552
 553   local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
 554
 555   local $SIG{HUP} = 'IGNORE';
 556   local $SIG{INT} = 'IGNORE';
 557   local $SIG{QUIT} = 'IGNORE';
 558   local $SIG{TERM} = 'IGNORE';
 559   local $SIG{TSTP} = 'IGNORE';
 560   local $SIG{PIPE} = 'IGNORE';
 561
 562   my $oldAutoCommit = $FS::UID::AutoCommit;
 563   local $FS::UID::AutoCommit = 0;
 564   my $dbh = dbh;
 565
 566   foreach my $method ( qw(adjourn expire) ) {  # How many reasons?
 567     if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
 568       my $error = $new->insert_reason(
 569         'reason'        => $options->{'reason'},
 570         'date'          => $new->$method,
 571         'action'        => $method,
 572         'reason_otaker' => $options->{'reason_otaker'},
 573       );
 574       if ( $error ) {
 575         dbh->rollback if $oldAutoCommit;
 576         return "Error inserting cust_pkg_reason: $error";
 577       }
 578     }
 579   }
 580
 581   #save off and freeze RADIUS attributes for any associated svc_acct records
 582   my @svc_acct = ();
 583   if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
 584
 585                 #also check for specific exports?
 586                 # to avoid spurious modify export events
 587     @svc_acct = map  { $_->svc_x }
 588                 grep { $_->part_svc->svcdb eq 'svc_acct' }
 589                      $old->cust_svc;
 590
 591     $_->snapshot foreach @svc_acct;
 592
 593   }
 594
 595   my $error =  $new->export_pkg_change($old)
 596             || $new->SUPER::replace( $old,
 597                                      $options->{options}
 598                                        ? $options->{options}
 599                                        : ()
 600                                    );
 601   if ( $error ) {
 602     $dbh->rollback if $oldAutoCommit;
 603     return $error;
 604   }
 605
 606   #for prepaid packages,
 607   #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
 608   foreach my $old_svc_acct ( @svc_acct ) {
 609     my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
 610     my $s_error =
 611       $new_svc_acct->replace( $old_svc_acct,
 612                               'depend_jobnum' => $options->{depend_jobnum},
 613                             );
 614     if ( $s_error ) {
 615       $dbh->rollback if $oldAutoCommit;
 616       return $s_error;
 617     }
 618   }
 619
 620   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 621   '';
 622
 623 }
 624
 625 =item check
 626
 627 Checks all fields to make sure this is a valid billing item.  If there is an
 628 error, returns the error, otherwise returns false.  Called by the insert and
 629 replace methods.
 630
 631 =cut
 632
 633 sub check {
 634   my $self = shift;
 635
 636   if ( !$self->locationnum or $self->locationnum == -1 ) {
 637     $self->set('locationnum', $self->cust_main->ship_locationnum);
 638   }
 639
 640   my $error =
 641     $self->ut_numbern('pkgnum')
 642     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 643     || $self->ut_numbern('pkgpart')
 644     || $self->ut_foreign_keyn('contactnum',  'contact',       'contactnum' )
 645     || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
 646     || $self->ut_foreign_keyn('salesnum', 'sales', 'salesnum')
 647     || $self->ut_numbern('quantity')
 648     || $self->ut_numbern('start_date')
 649     || $self->ut_numbern('setup')
 650     || $self->ut_numbern('bill')
 651     || $self->ut_numbern('susp')
 652     || $self->ut_numbern('cancel')
 653     || $self->ut_numbern('adjourn')
 654     || $self->ut_numbern('resume')
 655     || $self->ut_numbern('expire')
 656     || $self->ut_numbern('dundate')
 657     || $self->ut_enum('no_auto', [ '', 'Y' ])
 658     || $self->ut_enum('waive_setup', [ '', 'Y' ])
 659     || $self->ut_textn('agent_pkgid')
 660     || $self->ut_enum('recur_show_zero', [ '', 'Y', 'N', ])
 661     || $self->ut_enum('setup_show_zero', [ '', 'Y', 'N', ])
 662     || $self->ut_foreign_keyn('main_pkgnum', 'cust_pkg', 'pkgnum')
 663     || $self->ut_foreign_keyn('pkglinknum', 'part_pkg_link', 'pkglinknum')
 664     || $self->ut_foreign_keyn('change_to_pkgnum', 'cust_pkg', 'pkgnum')
 665   ;
 666   return $error if $error;
 667
 668   return "A package with both start date (future start) and setup date (already started) will never bill"
 669     if $self->start_date && $self->setup && ! $upgrade;
 670
 671   return "A future unsuspend date can only be set for a package with a suspend date"
 672     if $self->resume and !$self->susp and !$self->adjourn;
 673
 674   $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
 675
 676   if ( $self->dbdef_table->column('manual_flag') ) {
 677     $self->manual_flag('') if $self->manual_flag eq ' ';
 678     $self->manual_flag =~ /^([01]?)$/
 679       or return "Illegal manual_flag ". $self->manual_flag;
 680     $self->manual_flag($1);
 681   }
 682
 683   $self->SUPER::check;
 684 }
 685
 686 =item check_pkgpart
 687
 688 Check the pkgpart to make sure it's allowed with the reg_code and/or
 689 promo_code of the package (if present) and with the customer's agent.
 690 Called from C<insert>, unless we are doing a package change that doesn't
 691 affect pkgpart.
 692
 693 =cut
 694
 695 sub check_pkgpart {
 696   my $self = shift;
 697
 698   # my $error = $self->ut_numbern('pkgpart'); # already done
 699
 700   my $error;
 701   if ( $self->reg_code ) {
 702
 703     unless ( grep { $self->pkgpart == $_->pkgpart }
 704              map  { $_->reg_code_pkg }
 705              qsearchs( 'reg_code', { 'code'     => $self->reg_code,
 706                                      'agentnum' => $self->cust_main->agentnum })
 707            ) {
 708       return "Unknown registration code";
 709     }
 710
 711   } elsif ( $self->promo_code ) {
 712
 713     my $promo_part_pkg =
 714       qsearchs('part_pkg', {
 715         'pkgpart'    => $self->pkgpart,
 716         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 717       } );
 718     return 'Unknown promotional code' unless $promo_part_pkg;
 719
 720   } else {
 721
 722     unless ( $disable_agentcheck ) {
 723       my $agent =
 724         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 725       return "agent ". $agent->agentnum. ':'. $agent->agent.
 726              " can't purchase pkgpart ". $self->pkgpart
 727         unless $agent->pkgpart_hashref->{ $self->pkgpart }
 728             || $agent->agentnum == $self->part_pkg->agentnum;
 729     }
 730
 731     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 732     return $error if $error;
 733
 734   }
 735
 736   '';
 737
 738 }
 739
 740 =item cancel [ OPTION => VALUE ... ]
 741
 742 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 743 in this package, then cancels the package itself (sets the cancel field to
 744 now).
 745
 746 Available options are:
 747
 748 =over 4
 749
 750 =item quiet - can be set true to supress email cancellation notices.
 751
 752 =item time -  can be set to cancel the package based on a specific future or
 753 historical date.  Using time ensures that the remaining amount is calculated
 754 correctly.  Note however that this is an immediate cancel and just changes
 755 the date.  You are PROBABLY looking to expire the account instead of using
 756 this.
 757
 758 =item reason - can be set to a cancellation reason (see L<FS:reason>),
 759 either a reasonnum of an existing reason, or passing a hashref will create
 760 a new reason.  The hashref should have the following keys: typenum - Reason
 761 type (see L<FS::reason_type>, reason - Text of the new reason.
 762
 763 =item date - can be set to a unix style timestamp to specify when to
 764 cancel (expire)
 765
 766 =item nobill - can be set true to skip billing if it might otherwise be done.
 767
 768 =item unused_credit - can be set to 1 to credit the remaining time, or 0 to
 769 not credit it.  This must be set (by change()) when changing the package
 770 to a different pkgpart or location, and probably shouldn't be in any other
 771 case.  If it's not set, the 'unused_credit_cancel' part_pkg option will
 772 be used.
 773
 774 =back
 775
 776 If there is an error, returns the error, otherwise returns false.
 777
 778 =cut
 779
 780 sub cancel {
 781   my( $self, %options ) = @_;
 782   my $error;
 783
 784   # pass all suspend/cancel actions to the main package
 785   if ( $self->main_pkgnum and !$options{'from_main'} ) {
 786     return $self->main_pkg->cancel(%options);
 787   }
 788
 789   my $conf = new FS::Conf;
 790
 791   warn "cust_pkg::cancel called with options".
 792        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 793     if $DEBUG;
 794
 795   local $SIG{HUP} = 'IGNORE';
 796   local $SIG{INT} = 'IGNORE';
 797   local $SIG{QUIT} = 'IGNORE';
 798   local $SIG{TERM} = 'IGNORE';
 799   local $SIG{TSTP} = 'IGNORE';
 800   local $SIG{PIPE} = 'IGNORE';
 801
 802   my $oldAutoCommit = $FS::UID::AutoCommit;
 803   local $FS::UID::AutoCommit = 0;
 804   my $dbh = dbh;
 805
 806   my $old = $self->select_for_update;
 807
 808   if ( $old->get('cancel') || $self->get('cancel') ) {
 809     dbh->rollback if $oldAutoCommit;
 810     return "";  # no error
 811   }
 812
 813   # XXX possibly set cancel_time to the expire date?
 814   my $cancel_time = $options{'time'} || time;
 815   my $date = $options{'date'} if $options{'date'}; # expire/cancel later
 816   $date = '' if ($date && $date <= $cancel_time);      # complain instead?
 817
 818   #race condition: usage could be ongoing until unprovisioned
 819   #resolved by performing a change package instead (which unprovisions) and
 820   #later cancelling
 821   if ( !$options{nobill} && !$date ) {
 822     # && $conf->exists('bill_usage_on_cancel') ) { #calc_cancel checks this
 823       my $copy = $self->new({$self->hash});
 824       my $error =
 825         $copy->cust_main->bill( 'pkg_list' => [ $copy ],
 826                                 'cancel'   => 1,
 827                                 'time'     => $cancel_time );
 828       warn "Error billing during cancel, custnum ".
 829         #$self->cust_main->custnum. ": $error"
 830         ": $error"
 831         if $error;
 832   }
 833
 834   if ( $options{'reason'} ) {
 835     $error = $self->insert_reason( 'reason' => $options{'reason'},
 836                                    'action' => $date ? 'expire' : 'cancel',
 837                                    'date'   => $date ? $date : $cancel_time,
 838                                    'reason_otaker' => $options{'reason_otaker'},
 839                                  );
 840     if ( $error ) {
 841       dbh->rollback if $oldAutoCommit;
 842       return "Error inserting cust_pkg_reason: $error";
 843     }
 844   }
 845
 846   my %svc_cancel_opt = ();
 847   $svc_cancel_opt{'date'} = $date if $date;
 848   foreach my $cust_svc (
 849     #schwartz
 850     map  { $_->[0] }
 851     sort { $a->[1] <=> $b->[1] }
 852     map  { [ $_, $_->svc_x ? $_->svc_x->table_info->{'cancel_weight'} : -1 ]; }
 853     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 854   ) {
 855     my $part_svc = $cust_svc->part_svc;
 856     next if ( defined($part_svc) and $part_svc->preserve );
 857     my $error = $cust_svc->cancel( %svc_cancel_opt );
 858
 859     if ( $error ) {
 860       $dbh->rollback if $oldAutoCommit;
 861       return 'Error '. ($svc_cancel_opt{'date'} ? 'expiring' : 'canceling' ).
 862              " cust_svc: $error";
 863     }
 864   }
 865
 866   unless ($date) {
 867     # credit remaining time if appropriate
 868     my $do_credit;
 869     if ( exists($options{'unused_credit'}) ) {
 870       $do_credit = $options{'unused_credit'};
 871     }
 872     else {
 873       $do_credit = $self->part_pkg->option('unused_credit_cancel', 1);
 874     }
 875     if ( $do_credit ) {
 876       my $error = $self->credit_remaining('cancel', $cancel_time);
 877       if ($error) {
 878         $dbh->rollback if $oldAutoCommit;
 879         return $error;
 880       }
 881     }
 882
 883   } #unless $date
 884
 885   my %hash = $self->hash;
 886   if ( $date ) {
 887     $hash{'expire'} = $date;
 888   } else {
 889     $hash{'cancel'} = $cancel_time;
 890   }
 891   $hash{'change_custnum'} = $options{'change_custnum'};
 892
 893   my $new = new FS::cust_pkg ( \%hash );
 894   $error = $new->replace( $self, options => { $self->options } );
 895   if ( $self->change_to_pkgnum ) {
 896     my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
 897     $error ||= $change_to->cancel || $change_to->delete;
 898   }
 899   if ( $error ) {
 900     $dbh->rollback if $oldAutoCommit;
 901     return $error;
 902   }
 903
 904   foreach my $supp_pkg ( $self->supplemental_pkgs ) {
 905     $error = $supp_pkg->cancel(%options, 'from_main' => 1);
 906     if ( $error ) {
 907       $dbh->rollback if $oldAutoCommit;
 908       return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
 909     }
 910   }
 911
 912   foreach my $usage ( $self->cust_pkg_usage ) {
 913     $error = $usage->delete;
 914     if ( $error ) {
 915       $dbh->rollback if $oldAutoCommit;
 916       return "deleting usage pools: $error";
 917     }
 918   }
 919
 920   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 921   return '' if $date; #no errors
 922
 923   my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
 924   if ( !$options{'quiet'} &&
 925         $conf->exists('emailcancel', $self->cust_main->agentnum) &&
 926         @invoicing_list ) {
 927     my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
 928     my $error = '';
 929     if ( $msgnum ) {
 930       my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
 931       $error = $msg_template->send( 'cust_main' => $self->cust_main,
 932                                     'object'    => $self );
 933     }
 934     else {
 935       $error = send_email(
 936         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 937         'to'      => \@invoicing_list,
 938         'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
 939         'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 940         'custnum' => $self->custnum,
 941         'msgtype' => '', #admin?
 942       );
 943     }
 944     #should this do something on errors?
 945   }
 946
 947   ''; #no errors
 948
 949 }
 950
 951 =item cancel_if_expired [ NOW_TIMESTAMP ]
 952
 953 Cancels this package if its expire date has been reached.
 954
 955 =cut
 956
 957 sub cancel_if_expired {
 958   my $self = shift;
 959   my $time = shift || time;
 960   return '' unless $self->expire && $self->expire <= $time;
 961   my $error = $self->cancel;
 962   if ( $error ) {
 963     return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
 964            $self->custnum. ": $error";
 965   }
 966   '';
 967 }
 968
 969 =item uncancel
 970
 971 "Un-cancels" this package: Orders a new package with the same custnum, pkgpart,
 972 locationnum, (other fields?).  Attempts to re-provision cancelled services
 973 using history information (errors at this stage are not fatal).
 974
 975 cust_pkg: pass a scalar reference, will be filled in with the new cust_pkg object
 976
 977 svc_fatal: service provisioning errors are fatal
 978
 979 svc_errors: pass an array reference, will be filled in with any provisioning errors
 980
 981 main_pkgnum: link the package as a supplemental package of this one.  For
 982 internal use only.
 983
 984 =cut
 985
 986 sub uncancel {
 987   my( $self, %options ) = @_;
 988
 989   #in case you try do do $uncancel-date = $cust_pkg->uncacel
 990   return '' unless $self->get('cancel');
 991
 992   if ( $self->main_pkgnum and !$options{'main_pkgnum'} ) {
 993     return $self->main_pkg->uncancel(%options);
 994   }
 995
 996   ##
 997   # Transaction-alize
 998   ##
 999
1000   local $SIG{HUP} = 'IGNORE';
1001   local $SIG{INT} = 'IGNORE';
1002   local $SIG{QUIT} = 'IGNORE';
1003   local $SIG{TERM} = 'IGNORE';
1004   local $SIG{TSTP} = 'IGNORE';
1005   local $SIG{PIPE} = 'IGNORE';
1006
1007   my $oldAutoCommit = $FS::UID::AutoCommit;
1008   local $FS::UID::AutoCommit = 0;
1009   my $dbh = dbh;
1010
1011   ##
1012   # insert the new package
1013   ##
1014
1015   my $cust_pkg = new FS::cust_pkg {
1016     last_bill       => ( $options{'last_bill'} || $self->get('last_bill') ),
1017     bill            => ( $options{'bill'}      || $self->get('bill')      ),
1018     uncancel        => time,
1019     uncancel_pkgnum => $self->pkgnum,
1020     main_pkgnum     => ($options{'main_pkgnum'} || ''),
1021     map { $_ => $self->get($_) } qw(
1022       custnum pkgpart locationnum
1023       setup
1024       susp adjourn resume expire start_date contract_end dundate
1025       change_date change_pkgpart change_locationnum
1026       manual_flag no_auto quantity agent_pkgid recur_show_zero setup_show_zero
1027     ),
1028   };
1029
1030   my $error = $cust_pkg->insert(
1031     'change' => 1, #supresses any referral credit to a referring customer
1032     'allow_pkgpart' => 1, # allow this even if the package def is disabled
1033   );
1034   if ($error) {
1035     $dbh->rollback if $oldAutoCommit;
1036     return $error;
1037   }
1038
1039   ##
1040   # insert services
1041   ##
1042
1043   #find historical services within this timeframe before the package cancel
1044   # (incompatible with "time" option to cust_pkg->cancel?)
1045   my $fuzz = 2 * 60; #2 minutes?  too much?   (might catch separate unprovision)
1046                      #            too little? (unprovisioing export delay?)
1047   my($end, $start) = ( $self->get('cancel'), $self->get('cancel') - $fuzz );
1048   my @h_cust_svc = $self->h_cust_svc( $end, $start );
1049
1050   my @svc_errors;
1051   foreach my $h_cust_svc (@h_cust_svc) {
1052     my $h_svc_x = $h_cust_svc->h_svc_x( $end, $start );
1053     #next unless $h_svc_x; #should this happen?
1054     (my $table = $h_svc_x->table) =~ s/^h_//;
1055     require "FS/$table.pm";
1056     my $class = "FS::$table";
1057     my $svc_x = $class->new( {
1058       'pkgnum'  => $cust_pkg->pkgnum,
1059       'svcpart' => $h_cust_svc->svcpart,
1060       map { $_ => $h_svc_x->get($_) } fields($table)
1061     } );
1062
1063     # radius_usergroup
1064     if ( $h_svc_x->isa('FS::h_svc_Radius_Mixin') ) {
1065       $svc_x->usergroup( [ $h_svc_x->h_usergroup($end, $start) ] );
1066     }
1067
1068     my $svc_error = $svc_x->insert;
1069     if ( $svc_error ) {
1070       if ( $options{svc_fatal} ) {
1071         $dbh->rollback if $oldAutoCommit;
1072         return $svc_error;
1073       } else {
1074         # if we've failed to insert the svc_x object, svc_Common->insert
1075         # will have removed the cust_svc already.  if not, then both records
1076         # were inserted but we failed for some other reason (export, most
1077         # likely).  in that case, report the error and delete the records.
1078         push @svc_errors, $svc_error;
1079         my $cust_svc = qsearchs('cust_svc', { 'svcnum' => $svc_x->svcnum });
1080         if ( $cust_svc ) {
1081           # except if export_insert failed, export_delete probably won't be
1082           # much better
1083           local $FS::svc_Common::noexport_hack = 1;
1084           my $cleanup_error = $svc_x->delete; # also deletes cust_svc
1085           if ( $cleanup_error ) { # and if THAT fails, then run away
1086             $dbh->rollback if $oldAutoCommit;
1087             return $cleanup_error;
1088           }
1089         }
1090       } # svc_fatal
1091     } # svc_error
1092   } #foreach $h_cust_svc
1093
1094   #these are pretty rare, but should handle them
1095   # - dsl_device (mac addresses)
1096   # - phone_device (mac addresses)
1097   # - dsl_note (ikano notes)
1098   # - domain_record (i.e. restore DNS information w/domains)
1099   # - inventory_item(?) (inventory w/un-cancelling service?)
1100   # - nas (svc_broaband nas stuff)
1101   #this stuff is unused in the wild afaik
1102   # - mailinglistmember
1103   # - router.svcnum?
1104   # - svc_domain.parent_svcnum?
1105   # - acct_snarf (ancient mail fetching config)
1106   # - cgp_rule (communigate)
1107   # - cust_svc_option (used by our Tron stuff)
1108   # - acct_rt_transaction (used by our time worked stuff)
1109
1110   ##
1111   # also move over any services that didn't unprovision at cancellation
1112   ##
1113
1114   foreach my $cust_svc ( qsearch('cust_svc', { pkgnum => $self->pkgnum } ) ) {
1115     $cust_svc->pkgnum( $cust_pkg->pkgnum );
1116     my $error = $cust_svc->replace;
1117     if ( $error ) {
1118       $dbh->rollback if $oldAutoCommit;
1119       return $error;
1120     }
1121   }
1122
1123   ##
1124   # Uncancel any supplemental packages, and make them supplemental to the
1125   # new one.
1126   ##
1127
1128   foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1129     my $new_pkg;
1130     $error = $supp_pkg->uncancel(%options, 'main_pkgnum' => $cust_pkg->pkgnum);
1131     if ( $error ) {
1132       $dbh->rollback if $oldAutoCommit;
1133       return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
1134     }
1135   }
1136
1137   ##
1138   # Finish
1139   ##
1140
1141   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1142
1143   ${ $options{cust_pkg} }   = $cust_pkg   if ref($options{cust_pkg});
1144   @{ $options{svc_errors} } = @svc_errors if ref($options{svc_errors});
1145
1146   '';
1147 }
1148
1149 =item unexpire
1150
1151 Cancels any pending expiration (sets the expire field to null).
1152
1153 If there is an error, returns the error, otherwise returns false.
1154
1155 =cut
1156
1157 sub unexpire {
1158   my( $self, %options ) = @_;
1159   my $error;
1160
1161   local $SIG{HUP} = 'IGNORE';
1162   local $SIG{INT} = 'IGNORE';
1163   local $SIG{QUIT} = 'IGNORE';
1164   local $SIG{TERM} = 'IGNORE';
1165   local $SIG{TSTP} = 'IGNORE';
1166   local $SIG{PIPE} = 'IGNORE';
1167
1168   my $oldAutoCommit = $FS::UID::AutoCommit;
1169   local $FS::UID::AutoCommit = 0;
1170   my $dbh = dbh;
1171
1172   my $old = $self->select_for_update;
1173
1174   my $pkgnum = $old->pkgnum;
1175   if ( $old->get('cancel') || $self->get('cancel') ) {
1176     dbh->rollback if $oldAutoCommit;
1177     return "Can't unexpire cancelled package $pkgnum";
1178     # or at least it's pointless
1179   }
1180
1181   unless ( $old->get('expire') && $self->get('expire') ) {
1182     dbh->rollback if $oldAutoCommit;
1183     return "";  # no error
1184   }
1185
1186   my %hash = $self->hash;
1187   $hash{'expire'} = '';
1188   my $new = new FS::cust_pkg ( \%hash );
1189   $error = $new->replace( $self, options => { $self->options } );
1190   if ( $error ) {
1191     $dbh->rollback if $oldAutoCommit;
1192     return $error;
1193   }
1194
1195   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1196
1197   ''; #no errors
1198
1199 }
1200
1201 =item suspend [ OPTION => VALUE ... ]
1202
1203 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1204 package, then suspends the package itself (sets the susp field to now).
1205
1206 Available options are:
1207
1208 =over 4
1209
1210 =item reason - can be set to a cancellation reason (see L<FS:reason>),
1211 either a reasonnum of an existing reason, or passing a hashref will create
1212 a new reason.  The hashref should have the following keys:
1213 - typenum - Reason type (see L<FS::reason_type>
1214 - reason - Text of the new reason.
1215
1216 =item date - can be set to a unix style timestamp to specify when to
1217 suspend (adjourn)
1218
1219 =item time - can be set to override the current time, for calculation
1220 of final invoices or unused-time credits
1221
1222 =item resume_date - can be set to a time when the package should be
1223 unsuspended.  This may be more convenient than calling C<unsuspend()>
1224 separately.
1225
1226 =item from_main - allows a supplemental package to be suspended, rather
1227 than redirecting the method call to its main package.  For internal use.
1228
1229 =back
1230
1231 If there is an error, returns the error, otherwise returns false.
1232
1233 =cut
1234
1235 sub suspend {
1236   my( $self, %options ) = @_;
1237   my $error;
1238
1239   # pass all suspend/cancel actions to the main package
1240   if ( $self->main_pkgnum and !$options{'from_main'} ) {
1241     return $self->main_pkg->suspend(%options);
1242   }
1243
1244   local $SIG{HUP} = 'IGNORE';
1245   local $SIG{INT} = 'IGNORE';
1246   local $SIG{QUIT} = 'IGNORE';
1247   local $SIG{TERM} = 'IGNORE';
1248   local $SIG{TSTP} = 'IGNORE';
1249   local $SIG{PIPE} = 'IGNORE';
1250
1251   my $oldAutoCommit = $FS::UID::AutoCommit;
1252   local $FS::UID::AutoCommit = 0;
1253   my $dbh = dbh;
1254
1255   my $old = $self->select_for_update;
1256
1257   my $pkgnum = $old->pkgnum;
1258   if ( $old->get('cancel') || $self->get('cancel') ) {
1259     dbh->rollback if $oldAutoCommit;
1260     return "Can't suspend cancelled package $pkgnum";
1261   }
1262
1263   if ( $old->get('susp') || $self->get('susp') ) {
1264     dbh->rollback if $oldAutoCommit;
1265     return "";  # no error                     # complain on adjourn?
1266   }
1267
1268   my $suspend_time = $options{'time'} || time;
1269   my $date = $options{date} if $options{date}; # adjourn/suspend later
1270   $date = '' if ($date && $date <= $suspend_time); # complain instead?
1271
1272   if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
1273     dbh->rollback if $oldAutoCommit;
1274     return "Package $pkgnum expires before it would be suspended.";
1275   }
1276
1277   # some false laziness with sub cancel
1278   if ( !$options{nobill} && !$date &&
1279        $self->part_pkg->option('bill_suspend_as_cancel',1) ) {
1280     # kind of a kludge--'bill_suspend_as_cancel' to avoid having to
1281     # make the entire cust_main->bill path recognize 'suspend' and
1282     # 'cancel' separately.
1283     warn "Billing $pkgnum on suspension (at $suspend_time)\n" if $DEBUG;
1284     my $copy = $self->new({$self->hash});
1285     my $error =
1286       $copy->cust_main->bill( 'pkg_list' => [ $copy ],
1287                               'cancel'   => 1,
1288                               'time'     => $suspend_time );
1289     warn "Error billing during suspend, custnum ".
1290       #$self->cust_main->custnum. ": $error"
1291       ": $error"
1292       if $error;
1293   }
1294
1295   if ( $options{'reason'} ) {
1296     $error = $self->insert_reason( 'reason' => $options{'reason'},
1297                                    'action' => $date ? 'adjourn' : 'suspend',
1298                                    'date'   => $date ? $date : $suspend_time,
1299                                    'reason_otaker' => $options{'reason_otaker'},
1300                                  );
1301     if ( $error ) {
1302       dbh->rollback if $oldAutoCommit;
1303       return "Error inserting cust_pkg_reason: $error";
1304     }
1305   }
1306
1307   my %hash = $self->hash;
1308   if ( $date ) {
1309     $hash{'adjourn'} = $date;
1310   } else {
1311     $hash{'susp'} = $suspend_time;
1312   }
1313
1314   my $resume_date = $options{'resume_date'} || 0;
1315   if ( $resume_date > ($date || $suspend_time) ) {
1316     $hash{'resume'} = $resume_date;
1317   }
1318
1319   $options{options} ||= {};
1320
1321   my $new = new FS::cust_pkg ( \%hash );
1322   $error = $new->replace( $self, options => { $self->options,
1323                                               %{ $options{options} },
1324                                             }
1325                         );
1326   if ( $error ) {
1327     $dbh->rollback if $oldAutoCommit;
1328     return $error;
1329   }
1330
1331   unless ( $date ) {
1332     # credit remaining time if appropriate
1333     if ( $self->part_pkg->option('unused_credit_suspend', 1) ) {
1334       my $error = $self->credit_remaining('suspend', $suspend_time);
1335       if ($error) {
1336         $dbh->rollback if $oldAutoCommit;
1337         return $error;
1338       }
1339     }
1340
1341     my @labels = ();
1342
1343     foreach my $cust_svc (
1344       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
1345     ) {
1346       my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1347
1348       $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1349         $dbh->rollback if $oldAutoCommit;
1350         return "Illegal svcdb value in part_svc!";
1351       };
1352       my $svcdb = $1;
1353       require "FS/$svcdb.pm";
1354
1355       my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1356       if ($svc) {
1357         $error = $svc->suspend;
1358         if ( $error ) {
1359           $dbh->rollback if $oldAutoCommit;
1360           return $error;
1361         }
1362         my( $label, $value ) = $cust_svc->label;
1363         push @labels, "$label: $value";
1364       }
1365     }
1366
1367     my $conf = new FS::Conf;
1368     if ( $conf->config('suspend_email_admin') ) {
1369
1370       my $error = send_email(
1371         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
1372                                    #invoice_from ??? well as good as any
1373         'to'      => $conf->config('suspend_email_admin'),
1374         'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
1375         'body'    => [
1376           "This is an automatic message from your Freeside installation\n",
1377           "informing you that the following customer package has been suspended:\n",
1378           "\n",
1379           'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1380           'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1381           ( map { "Service : $_\n" } @labels ),
1382         ],
1383         'custnum' => $self->custnum,
1384         'msgtype' => 'admin'
1385       );
1386
1387       if ( $error ) {
1388         warn "WARNING: can't send suspension admin email (suspending anyway): ".
1389              "$error\n";
1390       }
1391
1392     }
1393
1394   }
1395
1396   foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1397     $error = $supp_pkg->suspend(%options, 'from_main' => 1);
1398     if ( $error ) {
1399       $dbh->rollback if $oldAutoCommit;
1400       return "suspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1401     }
1402   }
1403
1404   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1405
1406   ''; #no errors
1407 }
1408
1409 =item credit_remaining MODE TIME
1410
1411 Generate a credit for this package for the time remaining in the current
1412 billing period.  MODE is either "suspend" or "cancel" (determines the
1413 credit type).  TIME is the time of suspension/cancellation.  Both arguments
1414 are mandatory.
1415
1416 =cut
1417
1418 sub credit_remaining {
1419   # Add a credit for remaining service
1420   my ($self, $mode, $time) = @_;
1421   die 'credit_remaining requires suspend or cancel'
1422     unless $mode eq 'suspend' or $mode eq 'cancel';
1423   die 'no suspend/cancel time' unless $time > 0;
1424
1425   my $conf = FS::Conf->new;
1426   my $reason_type = $conf->config($mode.'_credit_type');
1427
1428   my $last_bill = $self->getfield('last_bill') || 0;
1429   my $next_bill = $self->getfield('bill') || 0;
1430   if ( $last_bill > 0         # the package has been billed
1431       and $next_bill > 0      # the package has a next bill date
1432       and $next_bill >= $time # which is in the future
1433   ) {
1434     my $remaining_value = $self->calc_remain('time' => $time);
1435     if ( $remaining_value > 0 ) {
1436       warn "Crediting for $remaining_value on package ".$self->pkgnum."\n"
1437         if $DEBUG;
1438       my $error = $self->cust_main->credit(
1439         $remaining_value,
1440         'Credit for unused time on '. $self->part_pkg->pkg,
1441         'reason_type' => $reason_type,
1442       );
1443       return "Error crediting customer \$$remaining_value for unused time".
1444         " on ". $self->part_pkg->pkg. ": $error"
1445         if $error;
1446     } #if $remaining_value
1447   } #if $last_bill, etc.
1448   '';
1449 }
1450
1451 =item unsuspend [ OPTION => VALUE ... ]
1452
1453 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1454 package, then unsuspends the package itself (clears the susp field and the
1455 adjourn field if it is in the past).  If the suspend reason includes an
1456 unsuspension package, that package will be ordered.
1457
1458 Available options are:
1459
1460 =over 4
1461
1462 =item date
1463
1464 Can be set to a date to unsuspend the package in the future (the 'resume'
1465 field).
1466
1467 =item adjust_next_bill
1468
1469 Can be set true to adjust the next bill date forward by
1470 the amount of time the account was inactive.  This was set true by default
1471 in the past (from 1.4.2 and 1.5.0pre6 through 1.7.0), but now needs to be
1472 explicitly requested with this option or in the price plan.
1473
1474 =back
1475
1476 If there is an error, returns the error, otherwise returns false.
1477
1478 =cut
1479
1480 sub unsuspend {
1481   my( $self, %opt ) = @_;
1482   my $error;
1483
1484   # pass all suspend/cancel actions to the main package
1485   if ( $self->main_pkgnum and !$opt{'from_main'} ) {
1486     return $self->main_pkg->unsuspend(%opt);
1487   }
1488
1489   local $SIG{HUP} = 'IGNORE';
1490   local $SIG{INT} = 'IGNORE';
1491   local $SIG{QUIT} = 'IGNORE';
1492   local $SIG{TERM} = 'IGNORE';
1493   local $SIG{TSTP} = 'IGNORE';
1494   local $SIG{PIPE} = 'IGNORE';
1495
1496   my $oldAutoCommit = $FS::UID::AutoCommit;
1497   local $FS::UID::AutoCommit = 0;
1498   my $dbh = dbh;
1499
1500   my $old = $self->select_for_update;
1501
1502   my $pkgnum = $old->pkgnum;
1503   if ( $old->get('cancel') || $self->get('cancel') ) {
1504     $dbh->rollback if $oldAutoCommit;
1505     return "Can't unsuspend cancelled package $pkgnum";
1506   }
1507
1508   unless ( $old->get('susp') && $self->get('susp') ) {
1509     $dbh->rollback if $oldAutoCommit;
1510     return "";  # no error                     # complain instead?
1511   }
1512
1513   my $date = $opt{'date'};
1514   if ( $date and $date > time ) { # return an error if $date <= time?
1515
1516     if ( $old->get('expire') && $old->get('expire') < $date ) {
1517       $dbh->rollback if $oldAutoCommit;
1518       return "Package $pkgnum expires before it would be unsuspended.";
1519     }
1520
1521     my $new = new FS::cust_pkg { $self->hash };
1522     $new->set('resume', $date);
1523     $error = $new->replace($self, options => $self->options);
1524
1525     if ( $error ) {
1526       $dbh->rollback if $oldAutoCommit;
1527       return $error;
1528     }
1529     else {
1530       $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1531       return '';
1532     }
1533
1534   } #if $date
1535
1536   my @labels = ();
1537
1538   foreach my $cust_svc (
1539     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1540   ) {
1541     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1542
1543     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1544       $dbh->rollback if $oldAutoCommit;
1545       return "Illegal svcdb value in part_svc!";
1546     };
1547     my $svcdb = $1;
1548     require "FS/$svcdb.pm";
1549
1550     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1551     if ($svc) {
1552       $error = $svc->unsuspend;
1553       if ( $error ) {
1554         $dbh->rollback if $oldAutoCommit;
1555         return $error;
1556       }
1557       my( $label, $value ) = $cust_svc->label;
1558       push @labels, "$label: $value";
1559     }
1560
1561   }
1562
1563   my $cust_pkg_reason = $self->last_cust_pkg_reason('susp');
1564   my $reason = $cust_pkg_reason ? $cust_pkg_reason->reason : '';
1565
1566   my %hash = $self->hash;
1567   my $inactive = time - $hash{'susp'};
1568
1569   my $conf = new FS::Conf;
1570
1571   $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
1572     if $inactive > 0
1573     && ( $hash{'bill'} || $hash{'setup'} )
1574     && (    $opt{'adjust_next_bill'}
1575          || $conf->exists('unsuspend-always_adjust_next_bill_date')
1576          || $self->part_pkg->option('unsuspend_adjust_bill', 1)
1577        )
1578     && ! $self->option('suspend_bill',1)
1579     && (    ! $self->part_pkg->option('suspend_bill',1)
1580          || $self->option('no_suspend_bill',1)
1581        )
1582     && $hash{'order_date'} != $hash{'susp'}
1583   ;
1584
1585   $hash{'susp'} = '';
1586   $hash{'adjourn'} = '' if $hash{'adjourn'} and $hash{'adjourn'} < time;
1587   $hash{'resume'} = '' if !$hash{'adjourn'};
1588   my $new = new FS::cust_pkg ( \%hash );
1589   $error = $new->replace( $self, options => { $self->options } );
1590   if ( $error ) {
1591     $dbh->rollback if $oldAutoCommit;
1592     return $error;
1593   }
1594
1595   my $unsusp_pkg;
1596
1597   if ( $reason && $reason->unsuspend_pkgpart ) {
1598     my $part_pkg = FS::part_pkg->by_key($reason->unsuspend_pkgpart)
1599       or $error = "Unsuspend package definition ".$reason->unsuspend_pkgpart.
1600                   " not found.";
1601     my $start_date = $self->cust_main->next_bill_date
1602       if $reason->unsuspend_hold;
1603
1604     if ( $part_pkg ) {
1605       $unsusp_pkg = FS::cust_pkg->new({
1606           'custnum'     => $self->custnum,
1607           'pkgpart'     => $reason->unsuspend_pkgpart,
1608           'start_date'  => $start_date,
1609           'locationnum' => $self->locationnum,
1610           # discount? probably not...
1611       });
1612
1613       $error ||= $self->cust_main->order_pkg( 'cust_pkg' => $unsusp_pkg );
1614     }
1615
1616     if ( $error ) {
1617       $dbh->rollback if $oldAutoCommit;
1618       return $error;
1619     }
1620   }
1621
1622   if ( $conf->config('unsuspend_email_admin') ) {
1623
1624     my $error = send_email(
1625       'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
1626                                  #invoice_from ??? well as good as any
1627       'to'      => $conf->config('unsuspend_email_admin'),
1628       'subject' => 'FREESIDE NOTIFICATION: Customer package unsuspended',       'body'    => [
1629         "This is an automatic message from your Freeside installation\n",
1630         "informing you that the following customer package has been unsuspended:\n",
1631         "\n",
1632         'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1633         'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1634         ( map { "Service : $_\n" } @labels ),
1635         ($unsusp_pkg ?
1636           "An unsuspension fee was charged: ".
1637             $unsusp_pkg->part_pkg->pkg_comment."\n"
1638           : ''
1639         ),
1640       ],
1641       'custnum' => $self->custnum,
1642       'msgtype' => 'admin',
1643     );
1644
1645     if ( $error ) {
1646       warn "WARNING: can't send unsuspension admin email (unsuspending anyway): ".
1647            "$error\n";
1648     }
1649
1650   }
1651
1652   foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1653     $error = $supp_pkg->unsuspend(%opt, 'from_main' => 1);
1654     if ( $error ) {
1655       $dbh->rollback if $oldAutoCommit;
1656       return "unsuspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1657     }
1658   }
1659
1660   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1661
1662   ''; #no errors
1663 }
1664
1665 =item unadjourn
1666
1667 Cancels any pending suspension (sets the adjourn field to null).
1668
1669 If there is an error, returns the error, otherwise returns false.
1670
1671 =cut
1672
1673 sub unadjourn {
1674   my( $self, %options ) = @_;
1675   my $error;
1676
1677   local $SIG{HUP} = 'IGNORE';
1678   local $SIG{INT} = 'IGNORE';
1679   local $SIG{QUIT} = 'IGNORE';
1680   local $SIG{TERM} = 'IGNORE';
1681   local $SIG{TSTP} = 'IGNORE';
1682   local $SIG{PIPE} = 'IGNORE';
1683
1684   my $oldAutoCommit = $FS::UID::AutoCommit;
1685   local $FS::UID::AutoCommit = 0;
1686   my $dbh = dbh;
1687
1688   my $old = $self->select_for_update;
1689
1690   my $pkgnum = $old->pkgnum;
1691   if ( $old->get('cancel') || $self->get('cancel') ) {
1692     dbh->rollback if $oldAutoCommit;
1693     return "Can't unadjourn cancelled package $pkgnum";
1694     # or at least it's pointless
1695   }
1696
1697   if ( $old->get('susp') || $self->get('susp') ) {
1698     dbh->rollback if $oldAutoCommit;
1699     return "Can't unadjourn suspended package $pkgnum";
1700     # perhaps this is arbitrary
1701   }
1702
1703   unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1704     dbh->rollback if $oldAutoCommit;
1705     return "";  # no error
1706   }
1707
1708   my %hash = $self->hash;
1709   $hash{'adjourn'} = '';
1710   $hash{'resume'}  = '';
1711   my $new = new FS::cust_pkg ( \%hash );
1712   $error = $new->replace( $self, options => { $self->options } );
1713   if ( $error ) {
1714     $dbh->rollback if $oldAutoCommit;
1715     return $error;
1716   }
1717
1718   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1719
1720   ''; #no errors
1721
1722 }
1723
1724
1725 =item change HASHREF | OPTION => VALUE ...
1726
1727 Changes this package: cancels it and creates a new one, with a different
1728 pkgpart or locationnum or both.  All services are transferred to the new
1729 package (no change will be made if this is not possible).
1730
1731 Options may be passed as a list of key/value pairs or as a hash reference.
1732 Options are:
1733
1734 =over 4
1735
1736 =item locationnum
1737
1738 New locationnum, to change the location for this package.
1739
1740 =item cust_location
1741
1742 New FS::cust_location object, to create a new location and assign it
1743 to this package.
1744
1745 =item cust_main
1746
1747 New FS::cust_main object, to create a new customer and assign the new package
1748 to it.
1749
1750 =item pkgpart
1751
1752 New pkgpart (see L<FS::part_pkg>).
1753
1754 =item refnum
1755
1756 New refnum (see L<FS::part_referral>).
1757
1758 =item quantity
1759
1760 New quantity; if unspecified, the new package will have the same quantity
1761 as the old.
1762
1763 =item cust_pkg
1764
1765 "New" (existing) FS::cust_pkg object.  The package's services and other
1766 attributes will be transferred to this package.
1767
1768 =item keep_dates
1769
1770 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
1771 susp, adjourn, cancel, expire, and contract_end) to the new package.
1772
1773 =item unprotect_svcs
1774
1775 Normally, change() will rollback and return an error if some services
1776 can't be transferred (also see the I<cust_pkg-change_svcpart> config option).
1777 If unprotect_svcs is true, this method will transfer as many services as
1778 it can and then unconditionally cancel the old package.
1779
1780 =back
1781
1782 At least one of locationnum, cust_location, pkgpart, refnum, cust_main, or
1783 cust_pkg must be specified (otherwise, what's the point?)
1784
1785 Returns either the new FS::cust_pkg object or a scalar error.
1786
1787 For example:
1788
1789   my $err_or_new_cust_pkg = $old_cust_pkg->change
1790
1791 =cut
1792
1793 #some false laziness w/order
1794 sub change {
1795   my $self = shift;
1796   my $opt = ref($_[0]) ? shift : { @_ };
1797
1798   my $conf = new FS::Conf;
1799
1800   # Transactionize this whole mess
1801   local $SIG{HUP} = 'IGNORE';
1802   local $SIG{INT} = 'IGNORE';
1803   local $SIG{QUIT} = 'IGNORE';
1804   local $SIG{TERM} = 'IGNORE';
1805   local $SIG{TSTP} = 'IGNORE';
1806   local $SIG{PIPE} = 'IGNORE';
1807
1808   my $oldAutoCommit = $FS::UID::AutoCommit;
1809   local $FS::UID::AutoCommit = 0;
1810   my $dbh = dbh;
1811
1812   my $error;
1813
1814   my %hash = ();
1815
1816   my $time = time;
1817
1818   $hash{'setup'} = $time if $self->setup;
1819
1820   $hash{'change_date'} = $time;
1821   $hash{"change_$_"}  = $self->$_()
1822     foreach qw( pkgnum pkgpart locationnum );
1823
1824   if ( $opt->{'cust_location'} ) {
1825     $error = $opt->{'cust_location'}->find_or_insert;
1826     if ( $error ) {
1827       $dbh->rollback if $oldAutoCommit;
1828       return "creating location record: $error";
1829     }
1830     $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1831   }
1832
1833   if ( $opt->{'cust_pkg'} ) {
1834     # treat changing to a package with a different pkgpart as a
1835     # pkgpart change (because it is)
1836     $opt->{'pkgpart'} = $opt->{'cust_pkg'}->pkgpart;
1837   }
1838
1839   # whether to override pkgpart checking on the new package
1840   my $same_pkgpart = 1;
1841   if ( $opt->{'pkgpart'} and ( $opt->{'pkgpart'} != $self->pkgpart ) ) {
1842     $same_pkgpart = 0;
1843   }
1844
1845   my $unused_credit = 0;
1846   my $keep_dates = $opt->{'keep_dates'};
1847   # Special case.  If the pkgpart is changing, and the customer is
1848   # going to be credited for remaining time, don't keep setup, bill,
1849   # or last_bill dates, and DO pass the flag to cancel() to credit
1850   # the customer.
1851   if ( $opt->{'pkgpart'}
1852        and $opt->{'pkgpart'} != $self->pkgpart
1853        and $self->part_pkg->option('unused_credit_change', 1) ) {
1854     $unused_credit = 1;
1855     $keep_dates = 0;
1856     $hash{$_} = '' foreach qw(setup bill last_bill);
1857   }
1858
1859   if ( $keep_dates ) {
1860     foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1861                           resume start_date contract_end ) ) {
1862       $hash{$date} = $self->getfield($date);
1863     }
1864   }
1865   # always keep this date, regardless of anything
1866   # (the date of the package change is in a different field)
1867   $hash{'order_date'} = $self->getfield('order_date');
1868
1869   # allow $opt->{'locationnum'} = '' to specifically set it to null
1870   # (i.e. customer default location)
1871   $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
1872
1873   # usually this doesn't matter.  the two cases where it does are:
1874   # 1. unused_credit_change + pkgpart change + setup fee on the new package
1875   # and
1876   # 2. (more importantly) changing a package before it's billed
1877   $hash{'waive_setup'} = $self->waive_setup;
1878
1879   my $custnum = $self->custnum;
1880   if ( $opt->{cust_main} ) {
1881     my $cust_main = $opt->{cust_main};
1882     unless ( $cust_main->custnum ) {
1883       my $error = $cust_main->insert( @{ $opt->{cust_main_insert_args}||[] } );
1884       if ( $error ) {
1885         $dbh->rollback if $oldAutoCommit;
1886         return "inserting customer record: $error";
1887       }
1888     }
1889     $custnum = $cust_main->custnum;
1890   }
1891
1892   $hash{'contactnum'} = $opt->{'contactnum'} if $opt->{'contactnum'};
1893
1894   my $cust_pkg;
1895   if ( $opt->{'cust_pkg'} ) {
1896     # The target package already exists; update it to show that it was
1897     # changed from this package.
1898     $cust_pkg = $opt->{'cust_pkg'};
1899
1900     foreach ( qw( pkgnum pkgpart locationnum ) ) {
1901       $cust_pkg->set("change_$_", $self->get($_));
1902     }
1903     $cust_pkg->set('change_date', $time);
1904     $error = $cust_pkg->replace;
1905
1906   } else {
1907     # Create the new package.
1908     $cust_pkg = new FS::cust_pkg {
1909       custnum     => $custnum,
1910       locationnum => $opt->{'locationnum'},
1911       ( map {  $_ => ( $opt->{$_} || $self->$_() )  }
1912           qw( pkgpart quantity refnum salesnum )
1913       ),
1914       %hash,
1915     };
1916     $error = $cust_pkg->insert( 'change' => 1,
1917                                 'allow_pkgpart' => $same_pkgpart );
1918   }
1919   if ($error) {
1920     $dbh->rollback if $oldAutoCommit;
1921     return "inserting new package: $error";
1922   }
1923
1924   # Transfer services and cancel old package.
1925
1926   $error = $self->transfer($cust_pkg);
1927   if ($error and $error == 0) {
1928     # $old_pkg->transfer failed.
1929     $dbh->rollback if $oldAutoCommit;
1930     return "transferring $error";
1931   }
1932
1933   if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1934     warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1935     $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1936     if ($error and $error == 0) {
1937       # $old_pkg->transfer failed.
1938       $dbh->rollback if $oldAutoCommit;
1939       return "converting $error";
1940     }
1941   }
1942
1943   # We set unprotect_svcs when executing a "future package change".  It's
1944   # not a user-interactive operation, so returning an error means the
1945   # package change will just fail.  Rather than have that happen, we'll
1946   # let leftover services be deleted.
1947   if ($error > 0 and !$opt->{'unprotect_svcs'}) {
1948     # Transfers were successful, but we still had services left on the old
1949     # package.  We can't change the package under this circumstances, so abort.
1950     $dbh->rollback if $oldAutoCommit;
1951     return "unable to transfer all services";
1952   }
1953
1954   #reset usage if changing pkgpart
1955   # AND usage rollover is off (otherwise adds twice, now and at package bill)
1956   if ($self->pkgpart != $cust_pkg->pkgpart) {
1957     my $part_pkg = $cust_pkg->part_pkg;
1958     $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1959                                                  ? ()
1960                                                  : ( 'null' => 1 )
1961                                    )
1962       if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
1963
1964     if ($error) {
1965       $dbh->rollback if $oldAutoCommit;
1966       return "setting usage values: $error";
1967     }
1968   } else {
1969     # if NOT changing pkgpart, transfer any usage pools over
1970     foreach my $usage ($self->cust_pkg_usage) {
1971       $usage->set('pkgnum', $cust_pkg->pkgnum);
1972       $error = $usage->replace;
1973       if ( $error ) {
1974         $dbh->rollback if $oldAutoCommit;
1975         return "transferring usage pools: $error";
1976       }
1977     }
1978   }
1979
1980   # transfer discounts, if we're not changing pkgpart
1981   if ( $same_pkgpart ) {
1982     foreach my $old_discount ($self->cust_pkg_discount_active) {
1983       # don't remove the old discount, we may still need to bill that package.
1984       my $new_discount = new FS::cust_pkg_discount {
1985         'pkgnum'      => $cust_pkg->pkgnum,
1986         'discountnum' => $old_discount->discountnum,
1987         'months_used' => $old_discount->months_used,
1988       };
1989       $error = $new_discount->insert;
1990       if ( $error ) {
1991         $dbh->rollback if $oldAutoCommit;
1992         return "transferring discounts: $error";
1993       }
1994     }
1995   }
1996
1997   # transfer (copy) invoice details
1998   foreach my $detail ($self->cust_pkg_detail) {
1999     my $new_detail = FS::cust_pkg_detail->new({ $detail->hash });
2000     $new_detail->set('pkgdetailnum', '');
2001     $new_detail->set('pkgnum', $cust_pkg->pkgnum);
2002     $error = $new_detail->insert;
2003     if ( $error ) {
2004       $dbh->rollback if $oldAutoCommit;
2005       return "transferring package notes: $error";
2006     }
2007   }
2008
2009   my @new_supp_pkgs;
2010
2011   if ( !$opt->{'cust_pkg'} ) {
2012     # Order any supplemental packages.
2013     my $part_pkg = $cust_pkg->part_pkg;
2014     my @old_supp_pkgs = $self->supplemental_pkgs;
2015     foreach my $link ($part_pkg->supp_part_pkg_link) {
2016       my $old;
2017       foreach (@old_supp_pkgs) {
2018         if ($_->pkgpart == $link->dst_pkgpart) {
2019           $old = $_;
2020           $_->pkgpart(0); # so that it can't match more than once
2021         }
2022         last if $old;
2023       }
2024       # false laziness with FS::cust_main::Packages::order_pkg
2025       my $new = FS::cust_pkg->new({
2026           pkgpart       => $link->dst_pkgpart,
2027           pkglinknum    => $link->pkglinknum,
2028           custnum       => $custnum,
2029           main_pkgnum   => $cust_pkg->pkgnum,
2030           locationnum   => $cust_pkg->locationnum,
2031           start_date    => $cust_pkg->start_date,
2032           order_date    => $cust_pkg->order_date,
2033           expire        => $cust_pkg->expire,
2034           adjourn       => $cust_pkg->adjourn,
2035           contract_end  => $cust_pkg->contract_end,
2036           refnum        => $cust_pkg->refnum,
2037           discountnum   => $cust_pkg->discountnum,
2038           waive_setup   => $cust_pkg->waive_setup,
2039       });
2040       if ( $old and $opt->{'keep_dates'} ) {
2041         foreach (qw(setup bill last_bill)) {
2042           $new->set($_, $old->get($_));
2043         }
2044       }
2045       $error = $new->insert( allow_pkgpart => $same_pkgpart );
2046       # transfer services
2047       if ( $old ) {
2048         $error ||= $old->transfer($new);
2049       }
2050       if ( $error and $error > 0 ) {
2051         # no reason why this should ever fail, but still...
2052         $error = "Unable to transfer all services from supplemental package ".
2053           $old->pkgnum;
2054       }
2055       if ( $error ) {
2056         $dbh->rollback if $oldAutoCommit;
2057         return $error;
2058       }
2059       push @new_supp_pkgs, $new;
2060     }
2061   } # if !$opt->{'cust_pkg'}
2062     # because if there is one, then supplemental packages would already
2063     # have been created for it.
2064
2065   #Good to go, cancel old package.  Notify 'cancel' of whether to credit
2066   #remaining time.
2067   #Don't allow billing the package (preceding period packages and/or
2068   #outstanding usage) if we are keeping dates (i.e. location changing),
2069   #because the new package will be billed for the same date range.
2070   #Supplemental packages are also canceled here.
2071
2072   # during scheduled changes, avoid canceling the package we just
2073   # changed to (duh)
2074   $self->set('change_to_pkgnum' => '');
2075
2076   $error = $self->cancel(
2077     quiet          => 1,
2078     unused_credit  => $unused_credit,
2079     nobill         => $keep_dates,
2080     change_custnum => ( $self->custnum != $custnum ? $custnum : '' ),
2081   );
2082   if ($error) {
2083     $dbh->rollback if $oldAutoCommit;
2084     return "canceling old package: $error";
2085   }
2086
2087   if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
2088     #$self->cust_main
2089     my $error = $cust_pkg->cust_main->bill(
2090       'pkg_list' => [ $cust_pkg, @new_supp_pkgs ]
2091     );
2092     if ( $error ) {
2093       $dbh->rollback if $oldAutoCommit;
2094       return "billing new package: $error";
2095     }
2096   }
2097
2098   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2099
2100   $cust_pkg;
2101
2102 }
2103
2104 =item change_later OPTION => VALUE...
2105
2106 Schedule a package change for a later date.  This actually orders the new
2107 package immediately, but sets its start date for a future date, and sets
2108 the current package to expire on the same date.
2109
2110 If the package is already scheduled for a change, this can be called with
2111 'start_date' to change the scheduled date, or with pkgpart and/or
2112 locationnum to modify the package change.  To cancel the scheduled change
2113 entirely, see C<abort_change>.
2114
2115 Options include:
2116
2117 =over 4
2118
2119 =item start_date
2120
2121 The date for the package change.  Required, and must be in the future.
2122
2123 =item pkgpart
2124
2125 =item locationnum
2126
2127 =item quantity
2128
2129 The pkgpart. locationnum, and quantity of the new package, with the same
2130 meaning as in C<change>.
2131
2132 =back
2133
2134 =cut
2135
2136 sub change_later {
2137   my $self = shift;
2138   my $opt = ref($_[0]) ? shift : { @_ };
2139
2140   my $oldAutoCommit = $FS::UID::AutoCommit;
2141   local $FS::UID::AutoCommit = 0;
2142   my $dbh = dbh;
2143
2144   my $cust_main = $self->cust_main;
2145
2146   my $date = delete $opt->{'start_date'} or return 'start_date required';
2147
2148   if ( $date <= time ) {
2149     $dbh->rollback if $oldAutoCommit;
2150     return "start_date $date is in the past";
2151   }
2152
2153   my $error;
2154
2155   if ( $self->change_to_pkgnum ) {
2156     my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
2157     my $new_pkgpart = $opt->{'pkgpart'}
2158         if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $change_to->pkgpart;
2159     my $new_locationnum = $opt->{'locationnum'}
2160         if $opt->{'locationnum'} and $opt->{'locationnum'} != $change_to->locationnum;
2161     my $new_quantity = $opt->{'quantity'}
2162         if $opt->{'quantity'} and $opt->{'quantity'} != $change_to->quantity;
2163     if ( $new_pkgpart or $new_locationnum or $new_quantity ) {
2164       # it hasn't been billed yet, so in principle we could just edit
2165       # it in place (w/o a package change), but that's bad form.
2166       # So change the package according to the new options...
2167       my $err_or_pkg = $change_to->change(%$opt);
2168       if ( ref $err_or_pkg ) {
2169         # Then set that package up for a future start.
2170         $self->set('change_to_pkgnum', $err_or_pkg->pkgnum);
2171         $self->set('expire', $date); # in case it's different
2172         $err_or_pkg->set('start_date', $date);
2173         $err_or_pkg->set('change_date', '');
2174         $err_or_pkg->set('change_pkgnum', '');
2175
2176         $error = $self->replace       ||
2177                  $err_or_pkg->replace ||
2178                  $change_to->cancel   ||
2179                  $change_to->delete;
2180       } else {
2181         $error = $err_or_pkg;
2182       }
2183     } else { # change the start date only.
2184       $self->set('expire', $date);
2185       $change_to->set('start_date', $date);
2186       $error = $self->replace || $change_to->replace;
2187     }
2188     if ( $error ) {
2189       $dbh->rollback if $oldAutoCommit;
2190       return $error;
2191     } else {
2192       $dbh->commit if $oldAutoCommit;
2193       return '';
2194     }
2195   } # if $self->change_to_pkgnum
2196
2197   my $new_pkgpart = $opt->{'pkgpart'}
2198       if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $self->pkgpart;
2199   my $new_locationnum = $opt->{'locationnum'}
2200       if $opt->{'locationnum'} and $opt->{'locationnum'} != $self->locationnum;
2201   my $new_quantity = $opt->{'quantity'}
2202       if $opt->{'quantity'} and $opt->{'quantity'} != $self->quantity;
2203
2204   return '' unless $new_pkgpart or $new_locationnum or $new_quantity; # wouldn't do anything
2205
2206   # allow $opt->{'locationnum'} = '' to specifically set it to null
2207   # (i.e. customer default location)
2208   $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
2209
2210   my $new = FS::cust_pkg->new( {
2211     custnum     => $self->custnum,
2212     locationnum => $opt->{'locationnum'},
2213     start_date  => $date,
2214     map   {  $_ => ( $opt->{$_} || $self->$_() )  }
2215       qw( pkgpart quantity refnum salesnum )
2216   } );
2217   $error = $new->insert('change' => 1,
2218                         'allow_pkgpart' => ($new_pkgpart ? 0 : 1));
2219   if ( !$error ) {
2220     $self->set('change_to_pkgnum', $new->pkgnum);
2221     $self->set('expire', $date);
2222     $error = $self->replace;
2223   }
2224   if ( $error ) {
2225     $dbh->rollback if $oldAutoCommit;
2226   } else {
2227     $dbh->commit if $oldAutoCommit;
2228   }
2229
2230   $error;
2231 }
2232
2233 =item abort_change
2234
2235 Cancels a future package change scheduled by C<change_later>.
2236
2237 =cut
2238
2239 sub abort_change {
2240   my $self = shift;
2241   my $pkgnum = $self->change_to_pkgnum;
2242   my $change_to = FS::cust_pkg->by_key($pkgnum) if $pkgnum;
2243   my $error;
2244   if ( $change_to ) {
2245     $error = $change_to->cancel || $change_to->delete;
2246     return $error if $error;
2247   }
2248   $self->set('change_to_pkgnum', '');
2249   $self->set('expire', '');
2250   $self->replace;
2251 }
2252
2253 =item set_quantity QUANTITY
2254
2255 Change the package's quantity field.  This is one of the few package properties
2256 that can safely be changed without canceling and reordering the package
2257 (because it doesn't affect tax eligibility).  Returns an error or an
2258 empty string.
2259
2260 =cut
2261
2262 sub set_quantity {
2263   my $self = shift;
2264   $self = $self->replace_old; # just to make sure
2265   $self->quantity(shift);
2266   $self->replace;
2267 }
2268
2269 =item set_salesnum SALESNUM
2270
2271 Change the package's salesnum (sales person) field.  This is one of the few
2272 package properties that can safely be changed without canceling and reordering
2273 the package (because it doesn't affect tax eligibility).  Returns an error or
2274 an empty string.
2275
2276 =cut
2277
2278 sub set_salesnum {
2279   my $self = shift;
2280   $self = $self->replace_old; # just to make sure
2281   $self->salesnum(shift);
2282   $self->replace;
2283   # XXX this should probably reassign any credit that's already been given
2284 }
2285
2286 =item modify_charge OPTIONS
2287
2288 Change the properties of a one-time charge.  The following properties can
2289 be changed this way:
2290 - pkg: the package description
2291 - classnum: the package class
2292 - additional: arrayref of additional invoice details to add to this package
2293
2294 and, I<if the charge has not yet been billed>:
2295 - start_date: the date when it will be billed
2296 - amount: the setup fee to be charged
2297 - quantity: the multiplier for the setup fee
2298
2299 If you pass 'adjust_commission' => 1, and the classnum changes, and there are
2300 commission credits linked to this charge, they will be recalculated.
2301
2302 =cut
2303
2304 sub modify_charge {
2305   my $self = shift;
2306   my %opt = @_;
2307   my $part_pkg = $self->part_pkg;
2308   my $pkgnum = $self->pkgnum;
2309
2310   my $dbh = dbh;
2311   my $oldAutoCommit = $FS::UID::AutoCommit;
2312   local $FS::UID::AutoCommit = 0;
2313
2314   return "Can't use modify_charge except on one-time charges"
2315     unless $part_pkg->freq eq '0';
2316
2317   if ( length($opt{'pkg'}) and $part_pkg->pkg ne $opt{'pkg'} ) {
2318     $part_pkg->set('pkg', $opt{'pkg'});
2319   }
2320
2321   my %pkg_opt = $part_pkg->options;
2322   my $pkg_opt_modified = 0;
2323
2324   $opt{'additional'} ||= [];
2325   my $i;
2326   my @old_additional;
2327   foreach (grep /^additional/, keys %pkg_opt) {
2328     ($i) = ($_ =~ /^additional_info(\d+)$/);
2329     $old_additional[$i] = $pkg_opt{$_} if $i;
2330     delete $pkg_opt{$_};
2331   }
2332
2333   for ( $i = 0; exists($opt{'additional'}->[$i]); $i++ ) {
2334     $pkg_opt{ "additional_info$i" } = $opt{'additional'}->[$i];
2335     if (!exists($old_additional[$i])
2336         or $old_additional[$i] ne $opt{'additional'}->[$i])
2337     {
2338       $pkg_opt_modified = 1;
2339     }
2340   }
2341   $pkg_opt_modified = 1 if (scalar(@old_additional) - 1) != $i;
2342   $pkg_opt{'additional_count'} = $i if $i > 0;
2343
2344   my $old_classnum;
2345   if ( exists($opt{'classnum'}) and $part_pkg->classnum ne $opt{'classnum'} )
2346   {
2347     # remember it
2348     $old_classnum = $part_pkg->classnum;
2349     $part_pkg->set('classnum', $opt{'classnum'});
2350   }
2351
2352   if ( !$self->get('setup') ) {
2353     # not yet billed, so allow amount and quantity
2354     if ( exists($opt{'quantity'})
2355           and $opt{'quantity'} != $self->quantity
2356           and $opt{'quantity'} > 0 ) {
2357
2358       $self->set('quantity', $opt{'quantity'});
2359     }
2360     if ( exists($opt{'start_date'})
2361           and $opt{'start_date'} != $self->start_date ) {
2362
2363       $self->set('start_date', $opt{'start_date'});
2364     }
2365
2366     if ( exists($opt{'amount'})
2367           and $part_pkg->option('setup_fee') != $opt{'amount'}
2368           and $opt{'amount'} > 0 ) {
2369
2370       $pkg_opt{'setup_fee'} = $opt{'amount'};
2371       $pkg_opt_modified = 1;
2372
2373     }
2374   } # else simply ignore them; the UI shouldn't allow editing the fields
2375
2376   my $error;
2377   if ( $part_pkg->modified or $pkg_opt_modified ) {
2378     # can we safely modify the package def?
2379     # Yes, if it's not available for purchase, and this is the only instance
2380     # of it.
2381     if ( $part_pkg->disabled
2382          and FS::cust_pkg->count('pkgpart = '.$part_pkg->pkgpart) == 1
2383          and FS::quotation_pkg->count('pkgpart = '.$part_pkg->pkgpart) == 0
2384        ) {
2385       $error = $part_pkg->replace( options => \%pkg_opt );
2386     } else {
2387       # clone it
2388       $part_pkg = $part_pkg->clone;
2389       $part_pkg->set('disabled' => 'Y');
2390       $error = $part_pkg->insert( options => \%pkg_opt );
2391       # and associate this as yet-unbilled package to the new package def
2392       $self->set('pkgpart' => $part_pkg->pkgpart);
2393     }
2394     if ( $error ) {
2395       $dbh->rollback if $oldAutoCommit;
2396       return $error;
2397     }
2398   }
2399
2400   if ($self->modified) { # for quantity or start_date change, or if we had
2401                          # to clone the existing package def
2402     my $error = $self->replace;
2403     return $error if $error;
2404   }
2405   if (defined $old_classnum) {
2406     # fix invoice grouping records
2407     my $old_catname = $old_classnum
2408                       ? FS::pkg_class->by_key($old_classnum)->categoryname
2409                       : '';
2410     my $new_catname = $opt{'classnum'}
2411                       ? $part_pkg->pkg_class->categoryname
2412                       : '';
2413     if ( $old_catname ne $new_catname ) {
2414       foreach my $cust_bill_pkg ($self->cust_bill_pkg) {
2415         # (there should only be one...)
2416         my @display = qsearch( 'cust_bill_pkg_display', {
2417             'billpkgnum'  => $cust_bill_pkg->billpkgnum,
2418             'section'     => $old_catname,
2419         });
2420         foreach (@display) {
2421           $_->set('section', $new_catname);
2422           $error = $_->replace;
2423           if ( $error ) {
2424             $dbh->rollback if $oldAutoCommit;
2425             return $error;
2426           }
2427         }
2428       } # foreach $cust_bill_pkg
2429     }
2430
2431     if ( $opt{'adjust_commission'} ) {
2432       # fix commission credits...tricky.
2433       foreach my $cust_event ($self->cust_event) {
2434         my $part_event = $cust_event->part_event;
2435         foreach my $table (qw(sales agent)) {
2436           my $class =
2437             "FS::part_event::Action::Mixin::credit_${table}_pkg_class";
2438           my $credit = qsearchs('cust_credit', {
2439               'eventnum' => $cust_event->eventnum,
2440           });
2441           if ( $part_event->isa($class) ) {
2442             # Yes, this results in current commission rates being applied
2443             # retroactively to a one-time charge.  For accounting purposes
2444             # there ought to be some kind of time limit on doing this.
2445             my $amount = $part_event->_calc_credit($self);
2446             if ( $credit and $credit->amount ne $amount ) {
2447               # Void the old credit.
2448               $error = $credit->void('Package class changed');
2449               if ( $error ) {
2450                 $dbh->rollback if $oldAutoCommit;
2451                 return "$error (adjusting commission credit)";
2452               }
2453             }
2454             # redo the event action to recreate the credit.
2455             local $@ = '';
2456             eval { $part_event->do_action( $self, $cust_event ) };
2457             if ( $@ ) {
2458               $dbh->rollback if $oldAutoCommit;
2459               return $@;
2460             }
2461           } # if $part_event->isa($class)
2462         } # foreach $table
2463       } # foreach $cust_event
2464     } # if $opt{'adjust_commission'}
2465   } # if defined $old_classnum
2466
2467   $dbh->commit if $oldAutoCommit;
2468   '';
2469 }
2470
2471
2472
2473 use Storable 'thaw';
2474 use MIME::Base64;
2475 use Data::Dumper;
2476 sub process_bulk_cust_pkg {
2477   my $job = shift;
2478   my $param = thaw(decode_base64(shift));
2479   warn Dumper($param) if $DEBUG;
2480
2481   my $old_part_pkg = qsearchs('part_pkg',
2482                               { pkgpart => $param->{'old_pkgpart'} });
2483   my $new_part_pkg = qsearchs('part_pkg',
2484                               { pkgpart => $param->{'new_pkgpart'} });
2485   die "Must select a new package type\n" unless $new_part_pkg;
2486   #my $keep_dates = $param->{'keep_dates'} || 0;
2487   my $keep_dates = 1; # there is no good reason to turn this off
2488
2489   local $SIG{HUP} = 'IGNORE';
2490   local $SIG{INT} = 'IGNORE';
2491   local $SIG{QUIT} = 'IGNORE';
2492   local $SIG{TERM} = 'IGNORE';
2493   local $SIG{TSTP} = 'IGNORE';
2494   local $SIG{PIPE} = 'IGNORE';
2495
2496   my $oldAutoCommit = $FS::UID::AutoCommit;
2497   local $FS::UID::AutoCommit = 0;
2498   my $dbh = dbh;
2499
2500   my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
2501
2502   my $i = 0;
2503   foreach my $old_cust_pkg ( @cust_pkgs ) {
2504     $i++;
2505     $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
2506     if ( $old_cust_pkg->getfield('cancel') ) {
2507       warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
2508         $old_cust_pkg->pkgnum."\n"
2509         if $DEBUG;
2510       next;
2511     }
2512     warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
2513       if $DEBUG;
2514     my $error = $old_cust_pkg->change(
2515       'pkgpart'     => $param->{'new_pkgpart'},
2516       'keep_dates'  => $keep_dates
2517     );
2518     if ( !ref($error) ) { # change returns the cust_pkg on success
2519       $dbh->rollback;
2520       die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
2521     }
2522   }
2523   $dbh->commit if $oldAutoCommit;
2524   return;
2525 }
2526
2527 =item last_bill
2528
2529 Returns the last bill date, or if there is no last bill date, the setup date.
2530 Useful for billing metered services.
2531
2532 =cut
2533
2534 sub last_bill {
2535   my $self = shift;
2536   return $self->setfield('last_bill', $_[0]) if @_;
2537   return $self->getfield('last_bill') if $self->getfield('last_bill');
2538   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
2539                                                   'edate'  => $self->bill,  } );
2540   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
2541 }
2542
2543 =item last_cust_pkg_reason ACTION
2544
2545 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
2546 Returns false if there is no reason or the package is not currenly ACTION'd
2547 ACTION is one of adjourn, susp, cancel, or expire.
2548
2549 =cut
2550
2551 sub last_cust_pkg_reason {
2552   my ( $self, $action ) = ( shift, shift );
2553   my $date = $self->get($action);
2554   qsearchs( {
2555               'table' => 'cust_pkg_reason',
2556               'hashref' => { 'pkgnum' => $self->pkgnum,
2557                              'action' => substr(uc($action), 0, 1),
2558                              'date'   => $date,
2559                            },
2560               'order_by' => 'ORDER BY num DESC LIMIT 1',
2561            } );
2562 }
2563
2564 =item last_reason ACTION
2565
2566 Returns the most recent ACTION FS::reason associated with the package.
2567 Returns false if there is no reason or the package is not currenly ACTION'd
2568 ACTION is one of adjourn, susp, cancel, or expire.
2569
2570 =cut
2571
2572 sub last_reason {
2573   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
2574   $cust_pkg_reason->reason
2575     if $cust_pkg_reason;
2576 }
2577
2578 =item part_pkg
2579
2580 Returns the definition for this billing item, as an FS::part_pkg object (see
2581 L<FS::part_pkg>).
2582
2583 =cut
2584
2585 sub part_pkg {
2586   my $self = shift;
2587   return $self->{'_pkgpart'} if $self->{'_pkgpart'};
2588   cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
2589   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
2590 }
2591
2592 =item old_cust_pkg
2593
2594 Returns the cancelled package this package was changed from, if any.
2595
2596 =cut
2597
2598 sub old_cust_pkg {
2599   my $self = shift;
2600   return '' unless $self->change_pkgnum;
2601   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
2602 }
2603
2604 =item change_cust_main
2605
2606 Returns the customter this package was detached to, if any.
2607
2608 =cut
2609
2610 sub change_cust_main {
2611   my $self = shift;
2612   return '' unless $self->change_custnum;
2613   qsearchs('cust_main', { 'custnum' => $self->change_custnum } );
2614 }
2615
2616 =item calc_setup
2617
2618 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
2619 item.
2620
2621 =cut
2622
2623 sub calc_setup {
2624   my $self = shift;
2625   $self->part_pkg->calc_setup($self, @_);
2626 }
2627
2628 =item calc_recur
2629
2630 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
2631 item.
2632
2633 =cut
2634
2635 sub calc_recur {
2636   my $self = shift;
2637   $self->part_pkg->calc_recur($self, @_);
2638 }
2639
2640 =item base_recur
2641
2642 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
2643 item.
2644
2645 =cut
2646
2647 sub base_recur {
2648   my $self = shift;
2649   $self->part_pkg->base_recur($self, @_);
2650 }
2651
2652 =item calc_remain
2653
2654 Calls the I<calc_remain> of the FS::part_pkg object associated with this
2655 billing item.
2656
2657 =cut
2658
2659 sub calc_remain {
2660   my $self = shift;
2661   $self->part_pkg->calc_remain($self, @_);
2662 }
2663
2664 =item calc_cancel
2665
2666 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
2667 billing item.
2668
2669 =cut
2670
2671 sub calc_cancel {
2672   my $self = shift;
2673   $self->part_pkg->calc_cancel($self, @_);
2674 }
2675
2676 =item cust_bill_pkg
2677
2678 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
2679
2680 =cut
2681
2682 sub cust_bill_pkg {
2683   my $self = shift;
2684   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
2685 }
2686
2687 =item cust_pkg_detail [ DETAILTYPE ]
2688
2689 Returns any customer package details for this package (see
2690 L<FS::cust_pkg_detail>).
2691
2692 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2693
2694 =cut
2695
2696 sub cust_pkg_detail {
2697   my $self = shift;
2698   my %hash = ( 'pkgnum' => $self->pkgnum );
2699   $hash{detailtype} = shift if @_;
2700   qsearch({
2701     'table'    => 'cust_pkg_detail',
2702     'hashref'  => \%hash,
2703     'order_by' => 'ORDER BY weight, pkgdetailnum',
2704   });
2705 }
2706
2707 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
2708
2709 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
2710
2711 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2712
2713 If there is an error, returns the error, otherwise returns false.
2714
2715 =cut
2716
2717 sub set_cust_pkg_detail {
2718   my( $self, $detailtype, @details ) = @_;
2719
2720   local $SIG{HUP} = 'IGNORE';
2721   local $SIG{INT} = 'IGNORE';
2722   local $SIG{QUIT} = 'IGNORE';
2723   local $SIG{TERM} = 'IGNORE';
2724   local $SIG{TSTP} = 'IGNORE';
2725   local $SIG{PIPE} = 'IGNORE';
2726
2727   my $oldAutoCommit = $FS::UID::AutoCommit;
2728   local $FS::UID::AutoCommit = 0;
2729   my $dbh = dbh;
2730
2731   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
2732     my $error = $current->delete;
2733     if ( $error ) {
2734       $dbh->rollback if $oldAutoCommit;
2735       return "error removing old detail: $error";
2736     }
2737   }
2738
2739   foreach my $detail ( @details ) {
2740     my $cust_pkg_detail = new FS::cust_pkg_detail {
2741       'pkgnum'     => $self->pkgnum,
2742       'detailtype' => $detailtype,
2743       'detail'     => $detail,
2744     };
2745     my $error = $cust_pkg_detail->insert;
2746     if ( $error ) {
2747       $dbh->rollback if $oldAutoCommit;
2748       return "error adding new detail: $error";
2749     }
2750
2751   }
2752
2753   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2754   '';
2755
2756 }
2757
2758 =item cust_event
2759
2760 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
2761
2762 =cut
2763
2764 #false laziness w/cust_bill.pm
2765 sub cust_event {
2766   my $self = shift;
2767   qsearch({
2768     'table'     => 'cust_event',
2769     'addl_from' => 'JOIN part_event USING ( eventpart )',
2770     'hashref'   => { 'tablenum' => $self->pkgnum },
2771     'extra_sql' => " AND eventtable = 'cust_pkg' ",
2772   });
2773 }
2774
2775 =item num_cust_event
2776
2777 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
2778
2779 =cut
2780
2781 #false laziness w/cust_bill.pm
2782 sub num_cust_event {
2783   my $self = shift;
2784   my $sql =
2785     "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
2786     "  WHERE tablenum = ? AND eventtable = 'cust_pkg'";
2787   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
2788   $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
2789   $sth->fetchrow_arrayref->[0];
2790 }
2791
2792 =item cust_svc [ SVCPART ] (old, deprecated usage)
2793
2794 =item cust_svc [ OPTION => VALUE ... ] (current usage)
2795
2796 =item cust_svc_unsorted [ OPTION => VALUE ... ]
2797
2798 Returns the services for this package, as FS::cust_svc objects (see
2799 L<FS::cust_svc>).  Available options are svcpart and svcdb.  If either is
2800 spcififed, returns only the matching services.
2801
2802 As an optimization, use the cust_svc_unsorted version if you are not displaying
2803 the results.
2804
2805 =cut
2806
2807 sub cust_svc {
2808   my $self = shift;
2809   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
2810   $self->_sort_cust_svc( $self->cust_svc_unsorted_arrayref(@_) );
2811 }
2812
2813 sub cust_svc_unsorted {
2814   my $self = shift;
2815   @{ $self->cust_svc_unsorted_arrayref(@_) };
2816 }
2817
2818 sub cust_svc_unsorted_arrayref {
2819   my $self = shift;
2820
2821   return [] unless $self->num_cust_svc(@_);
2822
2823   my %opt = ();
2824   if ( @_ && $_[0] =~ /^\d+/ ) {
2825     $opt{svcpart} = shift;
2826   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2827     %opt = %{ $_[0] };
2828   } elsif ( @_ ) {
2829     %opt = @_;
2830   }
2831
2832   my %search = (
2833     'table'   => 'cust_svc',
2834     'hashref' => { 'pkgnum' => $self->pkgnum },
2835   );
2836   if ( $opt{svcpart} ) {
2837     $search{hashref}->{svcpart} = $opt{'svcpart'};
2838   }
2839   if ( $opt{'svcdb'} ) {
2840     $search{addl_from} = ' LEFT JOIN part_svc USING ( svcpart ) ';
2841     $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{'svcdb'} );
2842   }
2843
2844   [ qsearch(\%search) ];
2845
2846 }
2847
2848 =item overlimit [ SVCPART ]
2849
2850 Returns the services for this package which have exceeded their
2851 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
2852 is specified, return only the matching services.
2853
2854 =cut
2855
2856 sub overlimit {
2857   my $self = shift;
2858   return () unless $self->num_cust_svc(@_);
2859   grep { $_->overlimit } $self->cust_svc(@_);
2860 }
2861
2862 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2863
2864 Returns historical services for this package created before END TIMESTAMP and
2865 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
2866 (see L<FS::h_cust_svc>).  If MODE is 'I' (for 'invoice'), services with the
2867 I<pkg_svc.hidden> flag will be omitted.
2868
2869 =cut
2870
2871 sub h_cust_svc {
2872   my $self = shift;
2873   warn "$me _h_cust_svc called on $self\n"
2874     if $DEBUG;
2875
2876   my ($end, $start, $mode) = @_;
2877   my @cust_svc = $self->_sort_cust_svc(
2878     [ qsearch( 'h_cust_svc',
2879       { 'pkgnum' => $self->pkgnum, },
2880       FS::h_cust_svc->sql_h_search(@_),
2881     ) ]
2882   );
2883   if ( defined($mode) && $mode eq 'I' ) {
2884     my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
2885     return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
2886   } else {
2887     return @cust_svc;
2888   }
2889 }
2890
2891 sub _sort_cust_svc {
2892   my( $self, $arrayref ) = @_;
2893
2894   my $sort =
2895     sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] };
2896
2897   my %pkg_svc = map { $_->svcpart => $_ }
2898                 qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
2899
2900   map  { $_->[0] }
2901   sort $sort
2902   map {
2903         my $pkg_svc = $pkg_svc{ $_->svcpart } || '';
2904         [ $_,
2905           $pkg_svc ? $pkg_svc->primary_svc : '',
2906           $pkg_svc ? $pkg_svc->quantity : 0,
2907         ];
2908       }
2909   @$arrayref;
2910
2911 }
2912
2913 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
2914
2915 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
2916
2917 Returns the number of services for this package.  Available options are svcpart
2918 and svcdb.  If either is spcififed, returns only the matching services.
2919
2920 =cut
2921
2922 sub num_cust_svc {
2923   my $self = shift;
2924
2925   return $self->{'_num_cust_svc'}
2926     if !scalar(@_)
2927        && exists($self->{'_num_cust_svc'})
2928        && $self->{'_num_cust_svc'} =~ /\d/;
2929
2930   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
2931     if $DEBUG > 2;
2932
2933   my %opt = ();
2934   if ( @_ && $_[0] =~ /^\d+/ ) {
2935     $opt{svcpart} = shift;
2936   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2937     %opt = %{ $_[0] };
2938   } elsif ( @_ ) {
2939     %opt = @_;
2940   }
2941
2942   my $select = 'SELECT COUNT(*) FROM cust_svc ';
2943   my $where = ' WHERE pkgnum = ? ';
2944   my @param = ($self->pkgnum);
2945
2946   if ( $opt{'svcpart'} ) {
2947     $where .= ' AND svcpart = ? ';
2948     push @param, $opt{'svcpart'};
2949   }
2950   if ( $opt{'svcdb'} ) {
2951     $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
2952     $where .= ' AND svcdb = ? ';
2953     push @param, $opt{'svcdb'};
2954   }
2955
2956   my $sth = dbh->prepare("$select $where") or die  dbh->errstr;
2957   $sth->execute(@param) or die $sth->errstr;
2958   $sth->fetchrow_arrayref->[0];
2959 }
2960
2961 =item available_part_svc
2962
2963 Returns a list of FS::part_svc objects representing services included in this
2964 package but not yet provisioned.  Each FS::part_svc object also has an extra
2965 field, I<num_avail>, which specifies the number of available services.
2966
2967 =cut
2968
2969 sub available_part_svc {
2970   my $self = shift;
2971
2972   my $pkg_quantity = $self->quantity || 1;
2973
2974   grep { $_->num_avail > 0 }
2975     map {
2976           my $part_svc = $_->part_svc;
2977           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
2978             $pkg_quantity * $_->quantity - $self->num_cust_svc($_->svcpart);
2979
2980           # more evil encapsulation breakage
2981           if($part_svc->{'Hash'}{'num_avail'} > 0) {
2982             my @exports = $part_svc->part_export_did;
2983             $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
2984           }
2985
2986           $part_svc;
2987         }
2988       $self->part_pkg->pkg_svc;
2989 }
2990
2991 =item part_svc [ OPTION => VALUE ... ]
2992
2993 Returns a list of FS::part_svc objects representing provisioned and available
2994 services included in this package.  Each FS::part_svc object also has the
2995 following extra fields:
2996
2997 =over 4
2998
2999 =item num_cust_svc
3000
3001 (count)
3002
3003 =item num_avail
3004
3005 (quantity - count)
3006
3007 =item cust_pkg_svc
3008
3009 (services) - array reference containing the provisioned services, as cust_svc objects
3010
3011 =back
3012
3013 Accepts two options:
3014
3015 =over 4
3016
3017 =item summarize_size
3018
3019 If true, will omit the extra cust_pkg_svc option for objects where num_cust_svc
3020 is this size or greater.
3021
3022 =item hide_discontinued
3023
3024 If true, will omit looking for services that are no longer avaialble in the
3025 package definition.
3026
3027 =back
3028
3029 =cut
3030
3031 #svcnum
3032 #label -> ($cust_svc->label)[1]
3033
3034 sub part_svc {
3035   my $self = shift;
3036   my %opt = @_;
3037
3038   my $pkg_quantity = $self->quantity || 1;
3039
3040   #XXX some sort of sort order besides numeric by svcpart...
3041   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
3042     my $pkg_svc = $_;
3043     my $part_svc = $pkg_svc->part_svc;
3044     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3045     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
3046     $part_svc->{'Hash'}{'num_avail'}    =
3047       max( 0, $pkg_quantity * $pkg_svc->quantity - $num_cust_svc );
3048     $part_svc->{'Hash'}{'cust_pkg_svc'} =
3049         $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
3050       unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
3051           && $num_cust_svc >= $opt{summarize_size};
3052     $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
3053     $part_svc;
3054   } $self->part_pkg->pkg_svc;
3055
3056   unless ( $opt{hide_discontinued} ) {
3057     #extras
3058     push @part_svc, map {
3059       my $part_svc = $_;
3060       my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3061       $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
3062       $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
3063       $part_svc->{'Hash'}{'cust_pkg_svc'} =
3064         $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
3065       $part_svc;
3066     } $self->extra_part_svc;
3067   }
3068
3069   @part_svc;
3070
3071 }
3072
3073 =item extra_part_svc
3074
3075 Returns a list of FS::part_svc objects corresponding to services in this
3076 package which are still provisioned but not (any longer) available in the
3077 package definition.
3078
3079 =cut
3080
3081 sub extra_part_svc {
3082   my $self = shift;
3083
3084   my $pkgnum  = $self->pkgnum;
3085   #my $pkgpart = $self->pkgpart;
3086
3087 #  qsearch( {
3088 #    'table'     => 'part_svc',
3089 #    'hashref'   => {},
3090 #    'extra_sql' =>
3091 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
3092 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
3093 #                       AND pkg_svc.pkgpart = ?
3094 #                       AND quantity > 0
3095 #                 )
3096 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
3097 #                       LEFT JOIN cust_pkg USING ( pkgnum )
3098 #                     WHERE cust_svc.svcpart = part_svc.svcpart
3099 #                       AND pkgnum = ?
3100 #                 )",
3101 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
3102 #  } );
3103
3104 #seems to benchmark slightly faster... (or did?)
3105
3106   my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
3107   my $pkgparts = join(',', @pkgparts);
3108
3109   qsearch( {
3110     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
3111     #MySQL doesn't grok DISINCT ON
3112     'select'      => 'DISTINCT part_svc.*',
3113     'table'       => 'part_svc',
3114     'addl_from'   =>
3115       "LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
3116                                AND pkg_svc.pkgpart IN ($pkgparts)
3117                                AND quantity > 0
3118                              )
3119        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
3120        LEFT JOIN cust_pkg USING ( pkgnum )
3121       ",
3122     'hashref'     => {},
3123     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
3124     'extra_param' => [ [$self->pkgnum=>'int'] ],
3125   } );
3126 }
3127
3128 =item status
3129
3130 Returns a short status string for this package, currently:
3131
3132 =over 4
3133
3134 =item on hold
3135
3136 =item not yet billed
3137
3138 =item one-time charge
3139
3140 =item active
3141
3142 =item suspended
3143
3144 =item cancelled
3145
3146 =back
3147
3148 =cut
3149
3150 sub status {
3151   my $self = shift;
3152
3153   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
3154
3155   return 'cancelled' if $self->get('cancel');
3156   return 'on hold' if $self->susp && ! $self->setup;
3157   return 'suspended' if $self->susp;
3158   return 'not yet billed' unless $self->setup;
3159   return 'one-time charge' if $freq =~ /^(0|$)/;
3160   return 'active';
3161 }
3162
3163 =item ucfirst_status
3164
3165 Returns the status with the first character capitalized.
3166
3167 =cut
3168
3169 sub ucfirst_status {
3170   ucfirst(shift->status);
3171 }
3172
3173 =item statuses
3174
3175 Class method that returns the list of possible status strings for packages
3176 (see L<the status method|/status>).  For example:
3177
3178   @statuses = FS::cust_pkg->statuses();
3179
3180 =cut
3181
3182 tie my %statuscolor, 'Tie::IxHash',
3183   'on hold'         => '7E0079', #purple!
3184   'not yet billed'  => '009999', #teal? cyan?
3185   'one-time charge' => '0000CC', #blue  #'000000',
3186   'active'          => '00CC00',
3187   'suspended'       => 'FF9900',
3188   'cancelled'       => 'FF0000',
3189 ;
3190
3191 sub statuses {
3192   my $self = shift; #could be class...
3193   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
3194   #                                    # mayble split btw one-time vs. recur
3195     keys %statuscolor;
3196 }
3197
3198 sub statuscolors {
3199   #my $self = shift;
3200   \%statuscolor;
3201 }
3202
3203 =item statuscolor
3204
3205 Returns a hex triplet color string for this package's status.
3206
3207 =cut
3208
3209 sub statuscolor {
3210   my $self = shift;
3211   $statuscolor{$self->status};
3212 }
3213
3214 =item pkg_label
3215
3216 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
3217 "pkg - comment" depending on user preference).
3218
3219 =cut
3220
3221 sub pkg_label {
3222   my $self = shift;
3223   my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
3224   $label = $self->pkgnum. ": $label"
3225     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
3226   $label;
3227 }
3228
3229 =item pkg_label_long
3230
3231 Returns a long label for this package, adding the primary service's label to
3232 pkg_label.
3233
3234 =cut
3235
3236 sub pkg_label_long {
3237   my $self = shift;
3238   my $label = $self->pkg_label;
3239   my $cust_svc = $self->primary_cust_svc;
3240   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
3241   $label;
3242 }
3243
3244 =item pkg_locale
3245
3246 Returns a customer-localized label for this package.
3247
3248 =cut
3249
3250 sub pkg_locale {
3251   my $self = shift;
3252   $self->part_pkg->pkg_locale( $self->cust_main->locale );
3253 }
3254
3255 =item primary_cust_svc
3256
3257 Returns a primary service (as FS::cust_svc object) if one can be identified.
3258
3259 =cut
3260
3261 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
3262
3263 sub primary_cust_svc {
3264   my $self = shift;
3265
3266   my @cust_svc = $self->cust_svc;
3267
3268   return '' unless @cust_svc; #no serivces - irrelevant then
3269
3270   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
3271
3272   # primary service as specified in the package definition
3273   # or exactly one service definition with quantity one
3274   my $svcpart = $self->part_pkg->svcpart;
3275   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
3276   return $cust_svc[0] if scalar(@cust_svc) == 1;
3277
3278   #couldn't identify one thing..
3279   return '';
3280 }
3281
3282 =item labels
3283
3284 Returns a list of lists, calling the label method for all services
3285 (see L<FS::cust_svc>) of this billing item.
3286
3287 =cut
3288
3289 sub labels {
3290   my $self = shift;
3291   map { [ $_->label ] } $self->cust_svc;
3292 }
3293
3294 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
3295
3296 Like the labels method, but returns historical information on services that
3297 were active as of END_TIMESTAMP and (optionally) not cancelled before
3298 START_TIMESTAMP.  If MODE is 'I' (for 'invoice'), services with the
3299 I<pkg_svc.hidden> flag will be omitted.
3300
3301 Returns a list of lists, calling the label method for all (historical) services
3302 (see L<FS::h_cust_svc>) of this billing item.
3303
3304 =cut
3305
3306 sub h_labels {
3307   my $self = shift;
3308   warn "$me _h_labels called on $self\n"
3309     if $DEBUG;
3310   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
3311 }
3312
3313 =item labels_short
3314
3315 Like labels, except returns a simple flat list, and shortens long
3316 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3317 identical services to one line that lists the service label and the number of
3318 individual services rather than individual items.
3319
3320 =cut
3321
3322 sub labels_short {
3323   shift->_labels_short( 'labels', @_ );
3324 }
3325
3326 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
3327
3328 Like h_labels, except returns a simple flat list, and shortens long
3329 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3330 identical services to one line that lists the service label and the number of
3331 individual services rather than individual items.
3332
3333 =cut
3334
3335 sub h_labels_short {
3336   shift->_labels_short( 'h_labels', @_ );
3337 }
3338
3339 sub _labels_short {
3340   my( $self, $method ) = ( shift, shift );
3341
3342   warn "$me _labels_short called on $self with $method method\n"
3343     if $DEBUG;
3344
3345   my $conf = new FS::Conf;
3346   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
3347
3348   warn "$me _labels_short populating \%labels\n"
3349     if $DEBUG;
3350
3351   my %labels;
3352   #tie %labels, 'Tie::IxHash';
3353   push @{ $labels{$_->[0]} }, $_->[1]
3354     foreach $self->$method(@_);
3355
3356   warn "$me _labels_short populating \@labels\n"
3357     if $DEBUG;
3358
3359   my @labels;
3360   foreach my $label ( keys %labels ) {
3361     my %seen = ();
3362     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
3363     my $num = scalar(@values);
3364     warn "$me _labels_short $num items for $label\n"
3365       if $DEBUG;
3366
3367     if ( $num > $max_same_services ) {
3368       warn "$me _labels_short   more than $max_same_services, so summarizing\n"
3369         if $DEBUG;
3370       push @labels, "$label ($num)";
3371     } else {
3372       if ( $conf->exists('cust_bill-consolidate_services') ) {
3373         warn "$me _labels_short   consolidating services\n"
3374           if $DEBUG;
3375         # push @labels, "$label: ". join(', ', @values);
3376         while ( @values ) {
3377           my $detail = "$label: ";
3378           $detail .= shift(@values). ', '
3379             while @values
3380                && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
3381           $detail =~ s/, $//;
3382           push @labels, $detail;
3383         }
3384         warn "$me _labels_short   done consolidating services\n"
3385           if $DEBUG;
3386       } else {
3387         warn "$me _labels_short   adding service data\n"
3388           if $DEBUG;
3389         push @labels, map { "$label: $_" } @values;
3390       }
3391     }
3392   }
3393
3394  @labels;
3395
3396 }
3397
3398 =item cust_main
3399
3400 Returns the parent customer object (see L<FS::cust_main>).
3401
3402 =cut
3403
3404 sub cust_main {
3405   my $self = shift;
3406   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
3407 }
3408
3409 =item balance
3410
3411 Returns the balance for this specific package, when using
3412 experimental package balance.
3413
3414 =cut
3415
3416 sub balance {
3417   my $self = shift;
3418   $self->cust_main->balance_pkgnum( $self->pkgnum );
3419 }
3420
3421 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
3422
3423 =item cust_location
3424
3425 Returns the location object, if any (see L<FS::cust_location>).
3426
3427 =item cust_location_or_main
3428
3429 If this package is associated with a location, returns the locaiton (see
3430 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
3431
3432 =item location_label [ OPTION => VALUE ... ]
3433
3434 Returns the label of the location object (see L<FS::cust_location>).
3435
3436 =cut
3437
3438 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
3439
3440 =item tax_locationnum
3441
3442 Returns the foreign key to a L<FS::cust_location> object for calculating
3443 tax on this package, as determined by the C<tax-pkg_address> and
3444 C<tax-ship_address> configuration flags.
3445
3446 =cut
3447
3448 sub tax_locationnum {
3449   my $self = shift;
3450   my $conf = FS::Conf->new;
3451   if ( $conf->exists('tax-pkg_address') ) {
3452     return $self->locationnum;
3453   }
3454   elsif ( $conf->exists('tax-ship_address') ) {
3455     return $self->cust_main->ship_locationnum;
3456   }
3457   else {
3458     return $self->cust_main->bill_locationnum;
3459   }
3460 }
3461
3462 =item tax_location
3463
3464 Returns the L<FS::cust_location> object for tax_locationnum.
3465
3466 =cut
3467
3468 sub tax_location {
3469   my $self = shift;
3470   my $conf = FS::Conf->new;
3471   if ( $conf->exists('tax-pkg_address') and $self->locationnum ) {
3472     return FS::cust_location->by_key($self->locationnum);
3473   }
3474   elsif ( $conf->exists('tax-ship_address') ) {
3475     return $self->cust_main->ship_location;
3476   }
3477   else {
3478     return $self->cust_main->bill_location;
3479   }
3480 }
3481
3482 =item seconds_since TIMESTAMP
3483
3484 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
3485 package have been online since TIMESTAMP, according to the session monitor.
3486
3487 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
3488 L<Time::Local> and L<Date::Parse> for conversion functions.
3489
3490 =cut
3491
3492 sub seconds_since {
3493   my($self, $since) = @_;
3494   my $seconds = 0;
3495
3496   foreach my $cust_svc (
3497     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
3498   ) {
3499     $seconds += $cust_svc->seconds_since($since);
3500   }
3501
3502   $seconds;
3503
3504 }
3505
3506 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
3507
3508 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
3509 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
3510 (exclusive).
3511
3512 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3513 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3514 functions.
3515
3516
3517 =cut
3518
3519 sub seconds_since_sqlradacct {
3520   my($self, $start, $end) = @_;
3521
3522   my $seconds = 0;
3523
3524   foreach my $cust_svc (
3525     grep {
3526       my $part_svc = $_->part_svc;
3527       $part_svc->svcdb eq 'svc_acct'
3528         && scalar($part_svc->part_export_usage);
3529     } $self->cust_svc
3530   ) {
3531     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
3532   }
3533
3534   $seconds;
3535
3536 }
3537
3538 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
3539
3540 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
3541 in this package for sessions ending between TIMESTAMP_START (inclusive) and
3542 TIMESTAMP_END
3543 (exclusive).
3544
3545 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3546 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3547 functions.
3548
3549 =cut
3550
3551 sub attribute_since_sqlradacct {
3552   my($self, $start, $end, $attrib) = @_;
3553
3554   my $sum = 0;
3555
3556   foreach my $cust_svc (
3557     grep {
3558       my $part_svc = $_->part_svc;
3559       scalar($part_svc->part_export_usage);
3560     } $self->cust_svc
3561   ) {
3562     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
3563   }
3564
3565   $sum;
3566
3567 }
3568
3569 =item quantity
3570
3571 =cut
3572
3573 sub quantity {
3574   my( $self, $value ) = @_;
3575   if ( defined($value) ) {
3576     $self->setfield('quantity', $value);
3577   }
3578   $self->getfield('quantity') || 1;
3579 }
3580
3581 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
3582
3583 Transfers as many services as possible from this package to another package.
3584
3585 The destination package can be specified by pkgnum by passing an FS::cust_pkg
3586 object.  The destination package must already exist.
3587
3588 Services are moved only if the destination allows services with the correct
3589 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
3590 this option with caution!  No provision is made for export differences
3591 between the old and new service definitions.  Probably only should be used
3592 when your exports for all service definitions of a given svcdb are identical.
3593 (attempt a transfer without it first, to move all possible svcpart-matching
3594 services)
3595
3596 Any services that can't be moved remain in the original package.
3597
3598 Returns an error, if there is one; otherwise, returns the number of services
3599 that couldn't be moved.
3600
3601 =cut
3602
3603 sub transfer {
3604   my ($self, $dest_pkgnum, %opt) = @_;
3605
3606   my $remaining = 0;
3607   my $dest;
3608   my %target;
3609
3610   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
3611     $dest = $dest_pkgnum;
3612     $dest_pkgnum = $dest->pkgnum;
3613   } else {
3614     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
3615   }
3616
3617   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
3618
3619   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
3620     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
3621   }
3622
3623   foreach my $cust_svc ($dest->cust_svc) {
3624     $target{$cust_svc->svcpart}--;
3625   }
3626
3627   my %svcpart2svcparts = ();
3628   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3629     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
3630     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
3631       next if exists $svcpart2svcparts{$svcpart};
3632       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
3633       $svcpart2svcparts{$svcpart} = [
3634         map  { $_->[0] }
3635         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
3636         map {
3637               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
3638                                                    'svcpart' => $_          } );
3639               [ $_,
3640                 $pkg_svc ? $pkg_svc->primary_svc : '',
3641                 $pkg_svc ? $pkg_svc->quantity : 0,
3642               ];
3643             }
3644
3645         grep { $_ != $svcpart }
3646         map  { $_->svcpart }
3647         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
3648       ];
3649       warn "alternates for svcpart $svcpart: ".
3650            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
3651         if $DEBUG;
3652     }
3653   }
3654
3655   my $error;
3656   foreach my $cust_svc ($self->cust_svc) {
3657     my $svcnum = $cust_svc->svcnum;
3658     if($target{$cust_svc->svcpart} > 0
3659        or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
3660       $target{$cust_svc->svcpart}--;
3661       my $new = new FS::cust_svc { $cust_svc->hash };
3662       $new->pkgnum($dest_pkgnum);
3663       $error = $new->replace($cust_svc);
3664     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3665       if ( $DEBUG ) {
3666         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
3667         warn "alternates to consider: ".
3668              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
3669       }
3670       my @alternate = grep {
3671                              warn "considering alternate svcpart $_: ".
3672                                   "$target{$_} available in new package\n"
3673                                if $DEBUG;
3674                              $target{$_} > 0;
3675                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
3676       if ( @alternate ) {
3677         warn "alternate(s) found\n" if $DEBUG;
3678         my $change_svcpart = $alternate[0];
3679         $target{$change_svcpart}--;
3680         my $new = new FS::cust_svc { $cust_svc->hash };
3681         $new->svcpart($change_svcpart);
3682         $new->pkgnum($dest_pkgnum);
3683         $error = $new->replace($cust_svc);
3684       } else {
3685         $remaining++;
3686       }
3687     } else {
3688       $remaining++
3689     }
3690     if ( $error ) {
3691       my @label = $cust_svc->label;
3692       return "service $label[1]: $error";
3693     }
3694   }
3695   return $remaining;
3696 }
3697
3698 =item grab_svcnums SVCNUM, SVCNUM ...
3699
3700 Change the pkgnum for the provided services to this packages.  If there is an
3701 error, returns the error, otherwise returns false.
3702
3703 =cut
3704
3705 sub grab_svcnums {
3706   my $self = shift;
3707   my @svcnum = @_;
3708
3709   local $SIG{HUP} = 'IGNORE';
3710   local $SIG{INT} = 'IGNORE';
3711   local $SIG{QUIT} = 'IGNORE';
3712   local $SIG{TERM} = 'IGNORE';
3713   local $SIG{TSTP} = 'IGNORE';
3714   local $SIG{PIPE} = 'IGNORE';
3715
3716   my $oldAutoCommit = $FS::UID::AutoCommit;
3717   local $FS::UID::AutoCommit = 0;
3718   my $dbh = dbh;
3719
3720   foreach my $svcnum (@svcnum) {
3721     my $cust_svc = qsearchs('cust_svc', { svcnum=>$svcnum } ) or do {
3722       $dbh->rollback if $oldAutoCommit;
3723       return "unknown svcnum $svcnum";
3724     };
3725     $cust_svc->pkgnum( $self->pkgnum );
3726     my $error = $cust_svc->replace;
3727     if ( $error ) {
3728       $dbh->rollback if $oldAutoCommit;
3729       return $error;
3730     }
3731   }
3732
3733   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3734   '';
3735
3736 }
3737
3738 =item reexport
3739
3740 This method is deprecated.  See the I<depend_jobnum> option to the insert and
3741 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
3742
3743 =cut
3744
3745 sub reexport {
3746   my $self = shift;
3747
3748   local $SIG{HUP} = 'IGNORE';
3749   local $SIG{INT} = 'IGNORE';
3750   local $SIG{QUIT} = 'IGNORE';
3751   local $SIG{TERM} = 'IGNORE';
3752   local $SIG{TSTP} = 'IGNORE';
3753   local $SIG{PIPE} = 'IGNORE';
3754
3755   my $oldAutoCommit = $FS::UID::AutoCommit;
3756   local $FS::UID::AutoCommit = 0;
3757   my $dbh = dbh;
3758
3759   foreach my $cust_svc ( $self->cust_svc ) {
3760     #false laziness w/svc_Common::insert
3761     my $svc_x = $cust_svc->svc_x;
3762     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
3763       my $error = $part_export->export_insert($svc_x);
3764       if ( $error ) {
3765         $dbh->rollback if $oldAutoCommit;
3766         return $error;
3767       }
3768     }
3769   }
3770
3771   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3772   '';
3773
3774 }
3775
3776 =item export_pkg_change OLD_CUST_PKG
3777
3778 Calls the "pkg_change" export action for all services attached to this package.
3779
3780 =cut
3781
3782 sub export_pkg_change {
3783   my( $self, $old )  = ( shift, shift );
3784
3785   local $SIG{HUP} = 'IGNORE';
3786   local $SIG{INT} = 'IGNORE';
3787   local $SIG{QUIT} = 'IGNORE';
3788   local $SIG{TERM} = 'IGNORE';
3789   local $SIG{TSTP} = 'IGNORE';
3790   local $SIG{PIPE} = 'IGNORE';
3791
3792   my $oldAutoCommit = $FS::UID::AutoCommit;
3793   local $FS::UID::AutoCommit = 0;
3794   my $dbh = dbh;
3795
3796   foreach my $svc_x ( map $_->svc_x, $self->cust_svc ) {
3797     my $error = $svc_x->export('pkg_change', $self, $old);
3798     if ( $error ) {
3799       $dbh->rollback if $oldAutoCommit;
3800       return $error;
3801     }
3802   }
3803
3804   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3805   '';
3806
3807 }
3808
3809 =item insert_reason
3810
3811 Associates this package with a (suspension or cancellation) reason (see
3812 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
3813 L<FS::reason>).
3814
3815 Available options are:
3816
3817 =over 4
3818
3819 =item reason
3820
3821 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.
3822
3823 =item reason_otaker
3824
3825 the access_user (see L<FS::access_user>) providing the reason
3826
3827 =item date
3828
3829 a unix timestamp
3830
3831 =item action
3832
3833 the action (cancel, susp, adjourn, expire) associated with the reason
3834
3835 =back
3836
3837 If there is an error, returns the error, otherwise returns false.
3838
3839 =cut
3840
3841 sub insert_reason {
3842   my ($self, %options) = @_;
3843
3844   my $otaker = $options{reason_otaker} ||
3845                $FS::CurrentUser::CurrentUser->username;
3846
3847   my $reasonnum;
3848   if ( $options{'reason'} =~ /^(\d+)$/ ) {
3849
3850     $reasonnum = $1;
3851
3852   } elsif ( ref($options{'reason'}) ) {
3853
3854     return 'Enter a new reason (or select an existing one)'
3855       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3856
3857     my $reason = new FS::reason({
3858       'reason_type' => $options{'reason'}->{'typenum'},
3859       'reason'      => $options{'reason'}->{'reason'},
3860     });
3861     my $error = $reason->insert;
3862     return $error if $error;
3863
3864     $reasonnum = $reason->reasonnum;
3865
3866   } else {
3867     return "Unparsable reason: ". $options{'reason'};
3868   }
3869
3870   my $cust_pkg_reason =
3871     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
3872                               'reasonnum' => $reasonnum,
3873                               'otaker'    => $otaker,
3874                               'action'    => substr(uc($options{'action'}),0,1),
3875                               'date'      => $options{'date'}
3876                                                ? $options{'date'}
3877                                                : time,
3878                             });
3879
3880   $cust_pkg_reason->insert;
3881 }
3882
3883 =item insert_discount
3884
3885 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
3886 inserting a new discount on the fly (see L<FS::discount>).
3887
3888 Available options are:
3889
3890 =over 4
3891
3892 =item discountnum
3893
3894 =back
3895
3896 If there is an error, returns the error, otherwise returns false.
3897
3898 =cut
3899
3900 sub insert_discount {
3901   #my ($self, %options) = @_;
3902   my $self = shift;
3903
3904   my $cust_pkg_discount = new FS::cust_pkg_discount {
3905     'pkgnum'      => $self->pkgnum,
3906     'discountnum' => $self->discountnum,
3907     'months_used' => 0,
3908     'end_date'    => '', #XXX
3909     #for the create a new discount case
3910     '_type'       => $self->discountnum__type,
3911     'amount'      => $self->discountnum_amount,
3912     'percent'     => $self->discountnum_percent,
3913     'months'      => $self->discountnum_months,
3914     'setup'      => $self->discountnum_setup,
3915     #'disabled'    => $self->discountnum_disabled,
3916   };
3917
3918   $cust_pkg_discount->insert;
3919 }
3920
3921 =item set_usage USAGE_VALUE_HASHREF
3922
3923 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3924 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3925 upbytes, downbytes, and totalbytes are appropriate keys.
3926
3927 All svc_accts which are part of this package have their values reset.
3928
3929 =cut
3930
3931 sub set_usage {
3932   my ($self, $valueref, %opt) = @_;
3933
3934   #only svc_acct can set_usage for now
3935   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3936     my $svc_x = $cust_svc->svc_x;
3937     $svc_x->set_usage($valueref, %opt)
3938       if $svc_x->can("set_usage");
3939   }
3940 }
3941
3942 =item recharge USAGE_VALUE_HASHREF
3943
3944 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3945 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3946 upbytes, downbytes, and totalbytes are appropriate keys.
3947
3948 All svc_accts which are part of this package have their values incremented.
3949
3950 =cut
3951
3952 sub recharge {
3953   my ($self, $valueref) = @_;
3954
3955   #only svc_acct can set_usage for now
3956   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3957     my $svc_x = $cust_svc->svc_x;
3958     $svc_x->recharge($valueref)
3959       if $svc_x->can("recharge");
3960   }
3961 }
3962
3963 =item cust_pkg_discount
3964
3965 =cut
3966
3967 sub cust_pkg_discount {
3968   my $self = shift;
3969   qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
3970 }
3971
3972 =item cust_pkg_discount_active
3973
3974 =cut
3975
3976 sub cust_pkg_discount_active {
3977   my $self = shift;
3978   grep { $_->status eq 'active' } $self->cust_pkg_discount;
3979 }
3980
3981 =item cust_pkg_usage
3982
3983 Returns a list of all voice usage counters attached to this package.
3984
3985 =cut
3986
3987 sub cust_pkg_usage {
3988   my $self = shift;
3989   qsearch('cust_pkg_usage', { pkgnum => $self->pkgnum });
3990 }
3991
3992 =item apply_usage OPTIONS
3993
3994 Takes the following options:
3995 - cdr: a call detail record (L<FS::cdr>)
3996 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
3997 - minutes: the maximum number of minutes to be charged
3998
3999 Finds available usage minutes for a call of this class, and subtracts
4000 up to that many minutes from the usage pool.  If the usage pool is empty,
4001 and the C<cdr-minutes_priority> global config option is set, minutes may
4002 be taken from other calls as well.  Either way, an allocation record will
4003 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
4004 number of minutes of usage applied to the call.
4005
4006 =cut
4007
4008 sub apply_usage {
4009   my ($self, %opt) = @_;
4010   my $cdr = $opt{cdr};
4011   my $rate_detail = $opt{rate_detail};
4012   my $minutes = $opt{minutes};
4013   my $classnum = $rate_detail->classnum;
4014   my $pkgnum = $self->pkgnum;
4015   my $custnum = $self->custnum;
4016
4017   local $SIG{HUP} = 'IGNORE';
4018   local $SIG{INT} = 'IGNORE';
4019   local $SIG{QUIT} = 'IGNORE';
4020   local $SIG{TERM} = 'IGNORE';
4021   local $SIG{TSTP} = 'IGNORE';
4022   local $SIG{PIPE} = 'IGNORE';
4023
4024   my $oldAutoCommit = $FS::UID::AutoCommit;
4025   local $FS::UID::AutoCommit = 0;
4026   my $dbh = dbh;
4027   my $order = FS::Conf->new->config('cdr-minutes_priority');
4028
4029   my $is_classnum;
4030   if ( $classnum ) {
4031     $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
4032   } else {
4033     $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
4034   }
4035   my @usage_recs = qsearch({
4036       'table'     => 'cust_pkg_usage',
4037       'addl_from' => ' JOIN part_pkg_usage       USING (pkgusagepart)'.
4038                      ' JOIN cust_pkg             USING (pkgnum)'.
4039                      ' JOIN part_pkg_usage_class USING (pkgusagepart)',
4040       'select'    => 'cust_pkg_usage.*',
4041       'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
4042                      " ( cust_pkg.custnum = $custnum AND ".
4043                      " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4044                      $is_classnum . ' AND '.
4045                      " cust_pkg_usage.minutes > 0",
4046       'order_by'  => " ORDER BY priority ASC",
4047   });
4048
4049   my $orig_minutes = $minutes;
4050   my $error;
4051   while (!$error and $minutes > 0 and @usage_recs) {
4052     my $cust_pkg_usage = shift @usage_recs;
4053     $cust_pkg_usage->select_for_update;
4054     my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
4055         pkgusagenum => $cust_pkg_usage->pkgusagenum,
4056         acctid      => $cdr->acctid,
4057         minutes     => min($cust_pkg_usage->minutes, $minutes),
4058     });
4059     $cust_pkg_usage->set('minutes',
4060       $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes
4061     );
4062     $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
4063     $minutes -= $cdr_cust_pkg_usage->minutes;
4064   }
4065   if ( $order and $minutes > 0 and !$error ) {
4066     # then try to steal minutes from another call
4067     my %search = (
4068         'table'     => 'cdr_cust_pkg_usage',
4069         'addl_from' => ' JOIN cust_pkg_usage        USING (pkgusagenum)'.
4070                        ' JOIN part_pkg_usage        USING (pkgusagepart)'.
4071                        ' JOIN cust_pkg              USING (pkgnum)'.
4072                        ' JOIN part_pkg_usage_class  USING (pkgusagepart)'.
4073                        ' JOIN cdr                   USING (acctid)',
4074         'select'    => 'cdr_cust_pkg_usage.*',
4075         'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
4076                        " ( cust_pkg.pkgnum = $pkgnum OR ".
4077                        " ( cust_pkg.custnum = $custnum AND ".
4078                        " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4079                        " part_pkg_usage_class.classnum = $classnum",
4080         'order_by'  => ' ORDER BY part_pkg_usage.priority ASC',
4081     );
4082     if ( $order eq 'time' ) {
4083       # find CDRs that are using minutes, but have a later startdate
4084       # than this call
4085       my $startdate = $cdr->startdate;
4086       if ($startdate !~ /^\d+$/) {
4087         die "bad cdr startdate '$startdate'";
4088       }
4089       $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
4090       # minimize needless reshuffling
4091       $search{'order_by'} .= ', cdr.startdate DESC';
4092     } else {
4093       # XXX may not work correctly with rate_time schedules.  Could
4094       # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
4095       # think...
4096       $search{'addl_from'} .=
4097         ' JOIN rate_detail'.
4098         ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
4099       if ( $order eq 'rate_high' ) {
4100         $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
4101                                 $rate_detail->min_charge;
4102         $search{'order_by'} .= ', rate_detail.min_charge ASC';
4103       } elsif ( $order eq 'rate_low' ) {
4104         $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
4105                                 $rate_detail->min_charge;
4106         $search{'order_by'} .= ', rate_detail.min_charge DESC';
4107       } else {
4108         #  this should really never happen
4109         die "invalid cdr-minutes_priority value '$order'\n";
4110       }
4111     }
4112     my @cdr_usage_recs = qsearch(\%search);
4113     my %reproc_cdrs;
4114     while (!$error and @cdr_usage_recs and $minutes > 0) {
4115       my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
4116       my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
4117       my $old_cdr = $cdr_cust_pkg_usage->cdr;
4118       $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
4119       $cdr_cust_pkg_usage->select_for_update;
4120       $old_cdr->select_for_update;
4121       $cust_pkg_usage->select_for_update;
4122       # in case someone else stole the usage from this CDR
4123       # while waiting for the lock...
4124       next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
4125       # steal the usage allocation and flag the old CDR for reprocessing
4126       $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
4127       # if the allocation is more minutes than we need, adjust it...
4128       my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
4129       if ( $delta > 0 ) {
4130         $cdr_cust_pkg_usage->set('minutes', $minutes);
4131         $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
4132         $error = $cust_pkg_usage->replace;
4133       }
4134       #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
4135       $error ||= $cdr_cust_pkg_usage->replace;
4136       # deduct the stolen minutes
4137       $minutes -= $cdr_cust_pkg_usage->minutes;
4138     }
4139     # after all minute-stealing is done, reset the affected CDRs
4140     foreach (values %reproc_cdrs) {
4141       $error ||= $_->set_status('');
4142       # XXX or should we just call $cdr->rate right here?
4143       # it's not like we can create a loop this way, since the min_charge
4144       # or call time has to go monotonically in one direction.
4145       # we COULD get some very deep recursions going, though...
4146     }
4147   } # if $order and $minutes
4148   if ( $error ) {
4149     $dbh->rollback;
4150     die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
4151   } else {
4152     $dbh->commit if $oldAutoCommit;
4153     return $orig_minutes - $minutes;
4154   }
4155 }
4156
4157 =item supplemental_pkgs
4158
4159 Returns a list of all packages supplemental to this one.
4160
4161 =cut
4162
4163 sub supplemental_pkgs {
4164   my $self = shift;
4165   qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
4166 }
4167
4168 =item main_pkg
4169
4170 Returns the package that this one is supplemental to, if any.
4171
4172 =cut
4173
4174 sub main_pkg {
4175   my $self = shift;
4176   if ( $self->main_pkgnum ) {
4177     return FS::cust_pkg->by_key($self->main_pkgnum);
4178   }
4179   return;
4180 }
4181
4182 =back
4183
4184 =head1 CLASS METHODS
4185
4186 =over 4
4187
4188 =item recurring_sql
4189
4190 Returns an SQL expression identifying recurring packages.
4191
4192 =cut
4193
4194 sub recurring_sql { "
4195   '0' != ( select freq from part_pkg
4196              where cust_pkg.pkgpart = part_pkg.pkgpart )
4197 "; }
4198
4199 =item onetime_sql
4200
4201 Returns an SQL expression identifying one-time packages.
4202
4203 =cut
4204
4205 sub onetime_sql { "
4206   '0' = ( select freq from part_pkg
4207             where cust_pkg.pkgpart = part_pkg.pkgpart )
4208 "; }
4209
4210 =item ordered_sql
4211
4212 Returns an SQL expression identifying ordered packages (recurring packages not
4213 yet billed).
4214
4215 =cut
4216
4217 sub ordered_sql {
4218    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
4219 }
4220
4221 =item active_sql
4222
4223 Returns an SQL expression identifying active packages.
4224
4225 =cut
4226
4227 sub active_sql {
4228   $_[0]->recurring_sql. "
4229   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4230   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4231   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4232 "; }
4233
4234 =item not_yet_billed_sql
4235
4236 Returns an SQL expression identifying packages which have not yet been billed.
4237
4238 =cut
4239
4240 sub not_yet_billed_sql { "
4241       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
4242   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4243   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4244 "; }
4245
4246 =item inactive_sql
4247
4248 Returns an SQL expression identifying inactive packages (one-time packages
4249 that are otherwise unsuspended/uncancelled).
4250
4251 =cut
4252
4253 sub inactive_sql { "
4254   ". $_[0]->onetime_sql(). "
4255   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4256   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4257   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4258 "; }
4259
4260 =item on_hold_sql
4261
4262 Returns an SQL expression identifying on-hold packages.
4263
4264 =cut
4265
4266 sub on_hold_sql {
4267   #$_[0]->recurring_sql(). ' AND '.
4268   "
4269         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel  = 0 )
4270     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp   != 0
4271     AND ( cust_pkg.setup  IS     NULL  OR cust_pkg.setup   = 0 )
4272   ";
4273 }
4274
4275 =item susp_sql
4276 =item suspended_sql
4277
4278 Returns an SQL expression identifying suspended packages.
4279
4280 =cut
4281
4282 sub suspended_sql { susp_sql(@_); }
4283 sub susp_sql {
4284   #$_[0]->recurring_sql(). ' AND '.
4285   "
4286         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
4287     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
4288     AND   cust_pkg.setup  IS NOT NULL AND cust_pkg.setup != 0
4289   ";
4290 }
4291
4292 =item cancel_sql
4293 =item cancelled_sql
4294
4295 Returns an SQL exprression identifying cancelled packages.
4296
4297 =cut
4298
4299 sub cancelled_sql { cancel_sql(@_); }
4300 sub cancel_sql {
4301   #$_[0]->recurring_sql(). ' AND '.
4302   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
4303 }
4304
4305 =item status_sql
4306
4307 Returns an SQL expression to give the package status as a string.
4308
4309 =cut
4310
4311 sub status_sql {
4312 "CASE
4313   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
4314   WHEN ( cust_pkg.susp IS NOT NULL AND cust_pkg.setup IS NULL ) THEN 'on hold'
4315   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
4316   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
4317   WHEN ".onetime_sql()." THEN 'one-time charge'
4318   ELSE 'active'
4319 END"
4320 }
4321
4322 =item search HASHREF
4323
4324 (Class method)
4325
4326 Returns a qsearch hash expression to search for parameters specified in HASHREF.
4327 Valid parameters are
4328
4329 =over 4
4330
4331 =item agentnum
4332
4333 =item magic
4334
4335 on hold, active, inactive (or one-time charge), suspended, cancel (or cancelled)
4336
4337 =item status
4338
4339 on hold, active, inactive (or one-time charge), suspended, cancel (or cancelled)
4340
4341 =item custom
4342
4343  boolean selects custom packages
4344
4345 =item classnum
4346
4347 =item pkgpart
4348
4349 pkgpart or arrayref or hashref of pkgparts
4350
4351 =item setup
4352
4353 arrayref of beginning and ending epoch date
4354
4355 =item last_bill
4356
4357 arrayref of beginning and ending epoch date
4358
4359 =item bill
4360
4361 arrayref of beginning and ending epoch date
4362
4363 =item adjourn
4364
4365 arrayref of beginning and ending epoch date
4366
4367 =item susp
4368
4369 arrayref of beginning and ending epoch date
4370
4371 =item expire
4372
4373 arrayref of beginning and ending epoch date
4374
4375 =item cancel
4376
4377 arrayref of beginning and ending epoch date
4378
4379 =item query
4380
4381 pkgnum or APKG_pkgnum
4382
4383 =item cust_fields
4384
4385 a value suited to passing to FS::UI::Web::cust_header
4386
4387 =item CurrentUser
4388
4389 specifies the user for agent virtualization
4390
4391 =item fcc_line
4392
4393 boolean; if true, returns only packages with more than 0 FCC phone lines.
4394
4395 =item state, country
4396
4397 Limit to packages with a service location in the specified state and country.
4398 For FCC 477 reporting, mostly.
4399
4400 =item location_cust
4401
4402 Limit to packages whose service locations are the same as the customer's
4403 default service location.
4404
4405 =item location_nocust
4406
4407 Limit to packages whose service locations are not the customer's default
4408 service location.
4409
4410 =item location_census
4411
4412 Limit to packages whose service locations have census tracts.
4413
4414 =item location_nocensus
4415
4416 Limit to packages whose service locations do not have a census tract.
4417
4418 =item location_geocode
4419
4420 Limit to packages whose locations have geocodes.
4421
4422 =item location_geocode
4423
4424 Limit to packages whose locations do not have geocodes.
4425
4426 =back
4427
4428 =cut
4429
4430 sub search {
4431   my ($class, $params) = @_;
4432   my @where = ();
4433
4434   ##
4435   # parse agent
4436   ##
4437
4438   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
4439     push @where,
4440       "cust_main.agentnum = $1";
4441   }
4442
4443   ##
4444   # parse cust_status
4445   ##
4446
4447   if ( $params->{'cust_status'} =~ /^([a-z]+)$/ ) {
4448     push @where, FS::cust_main->cust_status_sql . " = '$1' ";
4449   }
4450
4451   ##
4452   # parse customer sales person
4453   ##
4454
4455   if ( $params->{'cust_main_salesnum'} =~ /^(\d+)$/ ) {
4456     push @where, ($1 > 0) ? "cust_main.salesnum = $1"
4457                           : 'cust_main.salesnum IS NULL';
4458   }
4459
4460
4461   ##
4462   # parse sales person
4463   ##
4464
4465   if ( $params->{'salesnum'} =~ /^(\d+)$/ ) {
4466     push @where, ($1 > 0) ? "cust_pkg.salesnum = $1"
4467                           : 'cust_pkg.salesnum IS NULL';
4468   }
4469
4470   ##
4471   # parse custnum
4472   ##
4473
4474   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
4475     push @where,
4476       "cust_pkg.custnum = $1";
4477   }
4478
4479   ##
4480   # custbatch
4481   ##
4482
4483   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
4484     push @where,
4485       "cust_pkg.pkgbatch = '$1'";
4486   }
4487
4488   ##
4489   # parse status
4490   ##
4491
4492   if (    $params->{'magic'}  eq 'active'
4493        || $params->{'status'} eq 'active' ) {
4494
4495     push @where, FS::cust_pkg->active_sql();
4496
4497   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
4498             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
4499
4500     push @where, FS::cust_pkg->not_yet_billed_sql();
4501
4502   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
4503             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
4504
4505     push @where, FS::cust_pkg->inactive_sql();
4506
4507   } elsif (    $params->{'magic'}  =~ /^on[ _]hold$/
4508             || $params->{'status'} =~ /^on[ _]hold$/ ) {
4509
4510     push @where, FS::cust_pkg->on_hold_sql();
4511
4512
4513   } elsif (    $params->{'magic'}  eq 'suspended'
4514             || $params->{'status'} eq 'suspended'  ) {
4515
4516     push @where, FS::cust_pkg->suspended_sql();
4517
4518   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
4519             || $params->{'status'} =~ /^cancell?ed$/ ) {
4520
4521     push @where, FS::cust_pkg->cancelled_sql();
4522
4523   }
4524
4525   ###
4526   # parse package class
4527   ###
4528
4529   if ( exists($params->{'classnum'}) ) {
4530
4531     my @classnum = ();
4532     if ( ref($params->{'classnum'}) ) {
4533
4534       if ( ref($params->{'classnum'}) eq 'HASH' ) {
4535         @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
4536       } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
4537         @classnum = @{ $params->{'classnum'} };
4538       } else {
4539         die 'unhandled classnum ref '. $params->{'classnum'};
4540       }
4541
4542
4543     } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
4544       @classnum = ( $1 );
4545     }
4546
4547     if ( @classnum ) {
4548
4549       my @c_where = ();
4550       my @nums = grep $_, @classnum;
4551       push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
4552       my $null = scalar( grep { $_ eq '' } @classnum );
4553       push @c_where, 'part_pkg.classnum IS NULL' if $null;
4554
4555       if ( scalar(@c_where) == 1 ) {
4556         push @where, @c_where;
4557       } elsif ( @c_where ) {
4558         push @where, ' ( '. join(' OR ', @c_where). ' ) ';
4559       }
4560
4561     }
4562
4563
4564   }
4565
4566   ###
4567   # parse package report options
4568   ###
4569
4570   my @report_option = ();
4571   if ( exists($params->{'report_option'}) ) {
4572     if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
4573       @report_option = @{ $params->{'report_option'} };
4574     } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
4575       @report_option = split(',', $1);
4576     }
4577
4578   }
4579
4580   if (@report_option) {
4581     # this will result in the empty set for the dangling comma case as it should
4582     push @where,
4583       map{ "0 < ( SELECT count(*) FROM part_pkg_option
4584                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4585                     AND optionname = 'report_option_$_'
4586                     AND optionvalue = '1' )"
4587          } @report_option;
4588   }
4589
4590   foreach my $any ( grep /^report_option_any/, keys %$params ) {
4591
4592     my @report_option_any = ();
4593     if ( ref($params->{$any}) eq 'ARRAY' ) {
4594       @report_option_any = @{ $params->{$any} };
4595     } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
4596       @report_option_any = split(',', $1);
4597     }
4598
4599     if (@report_option_any) {
4600       # this will result in the empty set for the dangling comma case as it should
4601       push @where, ' ( '. join(' OR ',
4602         map{ "0 < ( SELECT count(*) FROM part_pkg_option
4603                       WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4604                       AND optionname = 'report_option_$_'
4605                       AND optionvalue = '1' )"
4606            } @report_option_any
4607       ). ' ) ';
4608     }
4609
4610   }
4611
4612   ###
4613   # parse custom
4614   ###
4615
4616   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
4617
4618   ###
4619   # parse fcc_line
4620   ###
4621
4622   push @where,  "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
4623                                                         if $params->{fcc_line};
4624
4625   ###
4626   # parse censustract
4627   ###
4628
4629   if ( exists($params->{'censustract'}) ) {
4630     $params->{'censustract'} =~ /^([.\d]*)$/;
4631     my $censustract = "cust_location.censustract = '$1'";
4632     $censustract .= ' OR cust_location.censustract is NULL' unless $1;
4633     push @where,  "( $censustract )";
4634   }
4635
4636   ###
4637   # parse censustract2
4638   ###
4639   if ( exists($params->{'censustract2'})
4640        && $params->{'censustract2'} =~ /^(\d*)$/
4641      )
4642   {
4643     if ($1) {
4644       push @where, "cust_location.censustract LIKE '$1%'";
4645     } else {
4646       push @where,
4647         "( cust_location.censustract = '' OR cust_location.censustract IS NULL )";
4648     }
4649   }
4650
4651   ###
4652   # parse country/state
4653   ###
4654   for (qw(state country)) { # parsing rules are the same for these
4655   if ( exists($params->{$_})
4656     && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
4657     {
4658       # XXX post-2.3 only--before that, state/country may be in cust_main
4659       push @where, "cust_location.$_ = '$1'";
4660     }
4661   }
4662
4663   ###
4664   # location_* flags
4665   ###
4666   if ( $params->{location_cust} xor $params->{location_nocust} ) {
4667     my $op = $params->{location_cust} ? '=' : '!=';
4668     push @where, "cust_location.locationnum $op cust_main.ship_locationnum";
4669   }
4670   if ( $params->{location_census} xor $params->{location_nocensus} ) {
4671     my $op = $params->{location_census} ? "IS NOT NULL" : "IS NULL";
4672     push @where, "cust_location.censustract $op";
4673   }
4674   if ( $params->{location_geocode} xor $params->{location_nogeocode} ) {
4675     my $op = $params->{location_geocode} ? "IS NOT NULL" : "IS NULL";
4676     push @where, "cust_location.geocode $op";
4677   }
4678
4679   ###
4680   # parse part_pkg
4681   ###
4682
4683   if ( ref($params->{'pkgpart'}) ) {
4684
4685     my @pkgpart = ();
4686     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
4687       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
4688     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
4689       @pkgpart = @{ $params->{'pkgpart'} };
4690     } else {
4691       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
4692     }
4693
4694     @pkgpart = grep /^(\d+)$/, @pkgpart;
4695
4696     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
4697
4698   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4699     push @where, "pkgpart = $1";
4700   }
4701
4702   ###
4703   # parse dates
4704   ###
4705
4706   my $orderby = '';
4707
4708   #false laziness w/report_cust_pkg.html
4709   my %disable = (
4710     'all'             => {},
4711     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
4712     'active'          => { 'susp'=>1, 'cancel'=>1 },
4713     'suspended'       => { 'cancel' => 1 },
4714     'cancelled'       => {},
4715     ''                => {},
4716   );
4717
4718   if( exists($params->{'active'} ) ) {
4719     # This overrides all the other date-related fields, and includes packages
4720     # that were active at some time during the interval.  It excludes:
4721     # - packages that were set up after the end of the interval
4722     # - packages that were canceled before the start of the interval
4723     # - packages that were suspended before the start of the interval
4724     #   and are still suspended now
4725     my($beginning, $ending) = @{$params->{'active'}};
4726     push @where,
4727       "cust_pkg.setup IS NOT NULL",
4728       "cust_pkg.setup <= $ending",
4729       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
4730       "(cust_pkg.susp   IS NULL OR cust_pkg.susp   >= $beginning )",
4731       "NOT (".FS::cust_pkg->onetime_sql . ")";
4732   }
4733   else {
4734     foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
4735
4736       next unless exists($params->{$field});
4737
4738       my($beginning, $ending) = @{$params->{$field}};
4739
4740       next if $beginning == 0 && $ending == 4294967295;
4741
4742       push @where,
4743         "cust_pkg.$field IS NOT NULL",
4744         "cust_pkg.$field >= $beginning",
4745         "cust_pkg.$field <= $ending";
4746
4747       $orderby ||= "ORDER BY cust_pkg.$field";
4748
4749     }
4750   }
4751
4752   $orderby ||= 'ORDER BY bill';
4753
4754   ###
4755   # parse magic, legacy, etc.
4756   ###
4757
4758   if ( $params->{'magic'} &&
4759        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
4760   ) {
4761
4762     $orderby = 'ORDER BY pkgnum';
4763
4764     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4765       push @where, "pkgpart = $1";
4766     }
4767
4768   } elsif ( $params->{'query'} eq 'pkgnum' ) {
4769
4770     $orderby = 'ORDER BY pkgnum';
4771
4772   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
4773
4774     $orderby = 'ORDER BY pkgnum';
4775
4776     push @where, '0 < (
4777       SELECT count(*) FROM pkg_svc
4778        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
4779          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
4780                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
4781                                      AND cust_svc.svcpart = pkg_svc.svcpart
4782                                 )
4783     )';
4784
4785   }
4786
4787   ##
4788   # setup queries, links, subs, etc. for the search
4789   ##
4790
4791   # here is the agent virtualization
4792   if ($params->{CurrentUser}) {
4793     my $access_user =
4794       qsearchs('access_user', { username => $params->{CurrentUser} });
4795
4796     if ($access_user) {
4797       push @where, $access_user->agentnums_sql('table'=>'cust_main');
4798     } else {
4799       push @where, "1=0";
4800     }
4801   } else {
4802     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
4803   }
4804
4805   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
4806
4807   my $addl_from = 'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
4808                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
4809                   'LEFT JOIN cust_location USING ( locationnum ) '.
4810                   FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg');
4811
4812   my $select;
4813   my $count_query;
4814   if ( $params->{'select_zip5'} ) {
4815     my $zip = 'cust_location.zip';
4816
4817     $select = "DISTINCT substr($zip,1,5) as zip";
4818     $orderby = "ORDER BY substr($zip,1,5)";
4819     $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
4820   } else {
4821     $select = join(', ',
4822                          'cust_pkg.*',
4823                          ( map "part_pkg.$_", qw( pkg freq ) ),
4824                          'pkg_class.classname',
4825                          'cust_main.custnum AS cust_main_custnum',
4826                          FS::UI::Web::cust_sql_fields(
4827                            $params->{'cust_fields'}
4828                          ),
4829                   );
4830     $count_query = 'SELECT COUNT(*)';
4831   }
4832
4833   $count_query .= " FROM cust_pkg $addl_from $extra_sql";
4834
4835   my $sql_query = {
4836     'table'       => 'cust_pkg',
4837     'hashref'     => {},
4838     'select'      => $select,
4839     'extra_sql'   => $extra_sql,
4840     'order_by'    => $orderby,
4841     'addl_from'   => $addl_from,
4842     'count_query' => $count_query,
4843   };
4844
4845 }
4846
4847 =item fcc_477_count
4848
4849 Returns a list of two package counts.  The first is a count of packages
4850 based on the supplied criteria and the second is the count of residential
4851 packages with those same criteria.  Criteria are specified as in the search
4852 method.
4853
4854 =cut
4855
4856 sub fcc_477_count {
4857   my ($class, $params) = @_;
4858
4859   my $sql_query = $class->search( $params );
4860
4861   my $count_sql = delete($sql_query->{'count_query'});
4862   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4863     or die "couldn't parse count_sql";
4864
4865   my $count_sth = dbh->prepare($count_sql)
4866     or die "Error preparing $count_sql: ". dbh->errstr;
4867   $count_sth->execute
4868     or die "Error executing $count_sql: ". $count_sth->errstr;
4869   my $count_arrayref = $count_sth->fetchrow_arrayref;
4870
4871   return ( @$count_arrayref );
4872
4873 }
4874
4875 =item tax_locationnum_sql
4876
4877 Returns an SQL expression for the tax location for a package, based
4878 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4879
4880 =cut
4881
4882 sub tax_locationnum_sql {
4883   my $conf = FS::Conf->new;
4884   if ( $conf->exists('tax-pkg_address') ) {
4885     'cust_pkg.locationnum';
4886   }
4887   elsif ( $conf->exists('tax-ship_address') ) {
4888     'cust_main.ship_locationnum';
4889   }
4890   else {
4891     'cust_main.bill_locationnum';
4892   }
4893 }
4894
4895 =item location_sql
4896
4897 Returns a list: the first item is an SQL fragment identifying matching
4898 packages/customers via location (taking into account shipping and package
4899 address taxation, if enabled), and subsequent items are the parameters to
4900 substitute for the placeholders in that fragment.
4901
4902 =cut
4903
4904 sub location_sql {
4905   my($class, %opt) = @_;
4906   my $ornull = $opt{'ornull'};
4907
4908   my $conf = new FS::Conf;
4909
4910   # '?' placeholders in _location_sql_where
4911   my $x = $ornull ? 3 : 2;
4912   my @bill_param = (
4913     ('district')x3,
4914     ('city')x3,
4915     ('county')x$x,
4916     ('state')x$x,
4917     'country'
4918   );
4919
4920   my $main_where;
4921   my @main_param;
4922   if ( $conf->exists('tax-ship_address') ) {
4923
4924     $main_where = "(
4925          (     ( ship_last IS NULL     OR  ship_last  = '' )
4926            AND ". _location_sql_where('cust_main', '', $ornull ). "
4927          )
4928       OR (       ship_last IS NOT NULL AND ship_last != ''
4929            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4930          )
4931     )";
4932     #    AND payby != 'COMP'
4933
4934     @main_param = ( @bill_param, @bill_param );
4935
4936   } else {
4937
4938     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4939     @main_param = @bill_param;
4940
4941   }
4942
4943   my $where;
4944   my @param;
4945   if ( $conf->exists('tax-pkg_address') ) {
4946
4947     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4948
4949     $where = " (
4950                     ( cust_pkg.locationnum IS     NULL AND $main_where )
4951                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
4952                )
4953              ";
4954     @param = ( @main_param, @bill_param );
4955
4956   } else {
4957
4958     $where = $main_where;
4959     @param = @main_param;
4960
4961   }
4962
4963   ( $where, @param );
4964
4965 }
4966
4967 #subroutine, helper for location_sql
4968 sub _location_sql_where {
4969   my $table  = shift;
4970   my $prefix = @_ ? shift : '';
4971   my $ornull = @_ ? shift : '';
4972
4973 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4974
4975   $ornull = $ornull ? ' OR ? IS NULL ' : '';
4976
4977   my $or_empty_city     = " OR ( ? = '' AND $table.${prefix}city     IS NULL )";
4978   my $or_empty_county   = " OR ( ? = '' AND $table.${prefix}county   IS NULL )";
4979   my $or_empty_state    = " OR ( ? = '' AND $table.${prefix}state    IS NULL )";
4980
4981   my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4982
4983 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
4984   "
4985         ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4986     AND ( $table.${prefix}city     = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4987     AND ( $table.${prefix}county   = ? $or_empty_county $ornull )
4988     AND ( $table.${prefix}state    = ? $or_empty_state  $ornull )
4989     AND   $table.${prefix}country  = ?
4990   ";
4991 }
4992
4993 sub _X_show_zero {
4994   my( $self, $what ) = @_;
4995
4996   my $what_show_zero = $what. '_show_zero';
4997   length($self->$what_show_zero())
4998     ? ($self->$what_show_zero() eq 'Y')
4999     : $self->part_pkg->$what_show_zero();
5000 }
5001
5002 =head1 SUBROUTINES
5003
5004 =over 4
5005
5006 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
5007
5008 CUSTNUM is a customer (see L<FS::cust_main>)
5009
5010 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
5011 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
5012 permitted.
5013
5014 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
5015 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
5016 new billing items.  An error is returned if this is not possible (see
5017 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
5018 parameter.
5019
5020 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
5021 newly-created cust_pkg objects.
5022
5023 REFNUM, if specified, will specify the FS::pkg_referral record to be created
5024 and inserted.  Multiple FS::pkg_referral records can be created by
5025 setting I<refnum> to an array reference of refnums or a hash reference with
5026 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
5027 record will be created corresponding to cust_main.refnum.
5028
5029 =cut
5030
5031 sub order {
5032   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
5033
5034   my $conf = new FS::Conf;
5035
5036   # Transactionize this whole mess
5037   local $SIG{HUP} = 'IGNORE';
5038   local $SIG{INT} = 'IGNORE';
5039   local $SIG{QUIT} = 'IGNORE';
5040   local $SIG{TERM} = 'IGNORE';
5041   local $SIG{TSTP} = 'IGNORE';
5042   local $SIG{PIPE} = 'IGNORE';
5043
5044   my $oldAutoCommit = $FS::UID::AutoCommit;
5045   local $FS::UID::AutoCommit = 0;
5046   my $dbh = dbh;
5047
5048   my $error;
5049 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
5050 #  return "Customer not found: $custnum" unless $cust_main;
5051
5052   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
5053     if $DEBUG;
5054
5055   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
5056                          @$remove_pkgnum;
5057
5058   my $change = scalar(@old_cust_pkg) != 0;
5059
5060   my %hash = ();
5061   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
5062
5063     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
5064          " to pkgpart ". $pkgparts->[0]. "\n"
5065       if $DEBUG;
5066
5067     my $err_or_cust_pkg =
5068       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
5069                                 'refnum'  => $refnum,
5070                               );
5071
5072     unless (ref($err_or_cust_pkg)) {
5073       $dbh->rollback if $oldAutoCommit;
5074       return $err_or_cust_pkg;
5075     }
5076
5077     push @$return_cust_pkg, $err_or_cust_pkg;
5078     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5079     return '';
5080
5081   }
5082
5083   # Create the new packages.
5084   foreach my $pkgpart (@$pkgparts) {
5085
5086     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
5087
5088     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
5089                                       pkgpart => $pkgpart,
5090                                       refnum  => $refnum,
5091                                       %hash,
5092                                     };
5093     $error = $cust_pkg->insert( 'change' => $change );
5094     push @$return_cust_pkg, $cust_pkg;
5095
5096     foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
5097       my $supp_pkg = FS::cust_pkg->new({
5098           custnum => $custnum,
5099           pkgpart => $link->dst_pkgpart,
5100           refnum  => $refnum,
5101           main_pkgnum => $cust_pkg->pkgnum,
5102           %hash,
5103       });
5104       $error ||= $supp_pkg->insert( 'change' => $change );
5105       push @$return_cust_pkg, $supp_pkg;
5106     }
5107
5108     if ($error) {
5109       $dbh->rollback if $oldAutoCommit;
5110       return $error;
5111     }
5112
5113   }
5114   # $return_cust_pkg now contains refs to all of the newly
5115   # created packages.
5116
5117   # Transfer services and cancel old packages.
5118   foreach my $old_pkg (@old_cust_pkg) {
5119
5120     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
5121       if $DEBUG;
5122
5123     foreach my $new_pkg (@$return_cust_pkg) {
5124       $error = $old_pkg->transfer($new_pkg);
5125       if ($error and $error == 0) {
5126         # $old_pkg->transfer failed.
5127         $dbh->rollback if $oldAutoCommit;
5128         return $error;
5129       }
5130     }
5131
5132     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
5133       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
5134       foreach my $new_pkg (@$return_cust_pkg) {
5135         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
5136         if ($error and $error == 0) {
5137           # $old_pkg->transfer failed.
5138         $dbh->rollback if $oldAutoCommit;
5139         return $error;
5140         }
5141       }
5142     }
5143
5144     if ($error > 0) {
5145       # Transfers were successful, but we went through all of the
5146       # new packages and still had services left on the old package.
5147       # We can't cancel the package under the circumstances, so abort.
5148       $dbh->rollback if $oldAutoCommit;
5149       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
5150     }
5151     $error = $old_pkg->cancel( quiet=>1 );
5152     if ($error) {
5153       $dbh->rollback;
5154       return $error;
5155     }
5156   }
5157   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5158   '';
5159 }
5160
5161 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
5162
5163 A bulk change method to change packages for multiple customers.
5164
5165 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
5166 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
5167 permitted.
5168
5169 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
5170 replace.  The services (see L<FS::cust_svc>) are moved to the
5171 new billing items.  An error is returned if this is not possible (see
5172 L<FS::pkg_svc>).
5173
5174 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
5175 newly-created cust_pkg objects.
5176
5177 =cut
5178
5179 sub bulk_change {
5180   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
5181
5182   # Transactionize this whole mess
5183   local $SIG{HUP} = 'IGNORE';
5184   local $SIG{INT} = 'IGNORE';
5185   local $SIG{QUIT} = 'IGNORE';
5186   local $SIG{TERM} = 'IGNORE';
5187   local $SIG{TSTP} = 'IGNORE';
5188   local $SIG{PIPE} = 'IGNORE';
5189
5190   my $oldAutoCommit = $FS::UID::AutoCommit;
5191   local $FS::UID::AutoCommit = 0;
5192   my $dbh = dbh;
5193
5194   my @errors;
5195   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
5196                          @$remove_pkgnum;
5197
5198   while(scalar(@old_cust_pkg)) {
5199     my @return = ();
5200     my $custnum = $old_cust_pkg[0]->custnum;
5201     my (@remove) = map { $_->pkgnum }
5202                    grep { $_->custnum == $custnum } @old_cust_pkg;
5203     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
5204
5205     my $error = order $custnum, $pkgparts, \@remove, \@return;
5206
5207     push @errors, $error
5208       if $error;
5209     push @$return_cust_pkg, @return;
5210   }
5211
5212   if (scalar(@errors)) {
5213     $dbh->rollback if $oldAutoCommit;
5214     return join(' / ', @errors);
5215   }
5216
5217   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5218   '';
5219 }
5220
5221 # Used by FS::Upgrade to migrate to a new database.
5222 sub _upgrade_data {  # class method
5223   my ($class, %opts) = @_;
5224   $class->_upgrade_otaker(%opts);
5225   my @statements = (
5226     # RT#10139, bug resulting in contract_end being set when it shouldn't
5227   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
5228     # RT#10830, bad calculation of prorate date near end of year
5229     # the date range for bill is December 2009, and we move it forward
5230     # one year if it's before the previous bill date (which it should
5231     # never be)
5232   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
5233   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
5234   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
5235     # RT6628, add order_date to cust_pkg
5236     'update cust_pkg set order_date = (select history_date from h_cust_pkg
5237         where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
5238         history_action = \'insert\') where order_date is null',
5239   );
5240   foreach my $sql (@statements) {
5241     my $sth = dbh->prepare($sql);
5242     $sth->execute or die $sth->errstr;
5243   }
5244 }
5245
5246 =back
5247
5248 =head1 BUGS
5249
5250 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
5251
5252 In sub order, the @pkgparts array (passed by reference) is clobbered.
5253
5254 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
5255 method to pass dates to the recur_prog expression, it should do so.
5256
5257 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
5258 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
5259 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
5260 configuration values.  Probably need a subroutine which decides what to do
5261 based on whether or not we've fetched the user yet, rather than a hash.  See
5262 FS::UID and the TODO.
5263
5264 Now that things are transactional should the check in the insert method be
5265 moved to check ?
5266
5267 =head1 SEE ALSO
5268
5269 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
5270 L<FS::pkg_svc>, schema.html from the base documentation
5271
5272 =cut
5273
5274 1;
5275