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' => '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 =item statuscolor
3199
3200 Returns a hex triplet color string for this package's status.
3201
3202 =cut
3203
3204 sub statuscolor {
3205   my $self = shift;
3206   $statuscolor{$self->status};
3207 }
3208
3209 =item pkg_label
3210
3211 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
3212 "pkg - comment" depending on user preference).
3213
3214 =cut
3215
3216 sub pkg_label {
3217   my $self = shift;
3218   my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
3219   $label = $self->pkgnum. ": $label"
3220     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
3221   $label;
3222 }
3223
3224 =item pkg_label_long
3225
3226 Returns a long label for this package, adding the primary service's label to
3227 pkg_label.
3228
3229 =cut
3230
3231 sub pkg_label_long {
3232   my $self = shift;
3233   my $label = $self->pkg_label;
3234   my $cust_svc = $self->primary_cust_svc;
3235   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
3236   $label;
3237 }
3238
3239 =item pkg_locale
3240
3241 Returns a customer-localized label for this package.
3242
3243 =cut
3244
3245 sub pkg_locale {
3246   my $self = shift;
3247   $self->part_pkg->pkg_locale( $self->cust_main->locale );
3248 }
3249
3250 =item primary_cust_svc
3251
3252 Returns a primary service (as FS::cust_svc object) if one can be identified.
3253
3254 =cut
3255
3256 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
3257
3258 sub primary_cust_svc {
3259   my $self = shift;
3260
3261   my @cust_svc = $self->cust_svc;
3262
3263   return '' unless @cust_svc; #no serivces - irrelevant then
3264
3265   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
3266
3267   # primary service as specified in the package definition
3268   # or exactly one service definition with quantity one
3269   my $svcpart = $self->part_pkg->svcpart;
3270   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
3271   return $cust_svc[0] if scalar(@cust_svc) == 1;
3272
3273   #couldn't identify one thing..
3274   return '';
3275 }
3276
3277 =item labels
3278
3279 Returns a list of lists, calling the label method for all services
3280 (see L<FS::cust_svc>) of this billing item.
3281
3282 =cut
3283
3284 sub labels {
3285   my $self = shift;
3286   map { [ $_->label ] } $self->cust_svc;
3287 }
3288
3289 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
3290
3291 Like the labels method, but returns historical information on services that
3292 were active as of END_TIMESTAMP and (optionally) not cancelled before
3293 START_TIMESTAMP.  If MODE is 'I' (for 'invoice'), services with the
3294 I<pkg_svc.hidden> flag will be omitted.
3295
3296 Returns a list of lists, calling the label method for all (historical) services
3297 (see L<FS::h_cust_svc>) of this billing item.
3298
3299 =cut
3300
3301 sub h_labels {
3302   my $self = shift;
3303   warn "$me _h_labels called on $self\n"
3304     if $DEBUG;
3305   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
3306 }
3307
3308 =item labels_short
3309
3310 Like labels, except returns a simple flat list, and shortens long
3311 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3312 identical services to one line that lists the service label and the number of
3313 individual services rather than individual items.
3314
3315 =cut
3316
3317 sub labels_short {
3318   shift->_labels_short( 'labels', @_ );
3319 }
3320
3321 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
3322
3323 Like h_labels, except returns a simple flat list, and shortens long
3324 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3325 identical services to one line that lists the service label and the number of
3326 individual services rather than individual items.
3327
3328 =cut
3329
3330 sub h_labels_short {
3331   shift->_labels_short( 'h_labels', @_ );
3332 }
3333
3334 sub _labels_short {
3335   my( $self, $method ) = ( shift, shift );
3336
3337   warn "$me _labels_short called on $self with $method method\n"
3338     if $DEBUG;
3339
3340   my $conf = new FS::Conf;
3341   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
3342
3343   warn "$me _labels_short populating \%labels\n"
3344     if $DEBUG;
3345
3346   my %labels;
3347   #tie %labels, 'Tie::IxHash';
3348   push @{ $labels{$_->[0]} }, $_->[1]
3349     foreach $self->$method(@_);
3350
3351   warn "$me _labels_short populating \@labels\n"
3352     if $DEBUG;
3353
3354   my @labels;
3355   foreach my $label ( keys %labels ) {
3356     my %seen = ();
3357     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
3358     my $num = scalar(@values);
3359     warn "$me _labels_short $num items for $label\n"
3360       if $DEBUG;
3361
3362     if ( $num > $max_same_services ) {
3363       warn "$me _labels_short   more than $max_same_services, so summarizing\n"
3364         if $DEBUG;
3365       push @labels, "$label ($num)";
3366     } else {
3367       if ( $conf->exists('cust_bill-consolidate_services') ) {
3368         warn "$me _labels_short   consolidating services\n"
3369           if $DEBUG;
3370         # push @labels, "$label: ". join(', ', @values);
3371         while ( @values ) {
3372           my $detail = "$label: ";
3373           $detail .= shift(@values). ', '
3374             while @values
3375                && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
3376           $detail =~ s/, $//;
3377           push @labels, $detail;
3378         }
3379         warn "$me _labels_short   done consolidating services\n"
3380           if $DEBUG;
3381       } else {
3382         warn "$me _labels_short   adding service data\n"
3383           if $DEBUG;
3384         push @labels, map { "$label: $_" } @values;
3385       }
3386     }
3387   }
3388
3389  @labels;
3390
3391 }
3392
3393 =item cust_main
3394
3395 Returns the parent customer object (see L<FS::cust_main>).
3396
3397 =cut
3398
3399 sub cust_main {
3400   my $self = shift;
3401   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
3402 }
3403
3404 =item balance
3405
3406 Returns the balance for this specific package, when using
3407 experimental package balance.
3408
3409 =cut
3410
3411 sub balance {
3412   my $self = shift;
3413   $self->cust_main->balance_pkgnum( $self->pkgnum );
3414 }
3415
3416 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
3417
3418 =item cust_location
3419
3420 Returns the location object, if any (see L<FS::cust_location>).
3421
3422 =item cust_location_or_main
3423
3424 If this package is associated with a location, returns the locaiton (see
3425 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
3426
3427 =item location_label [ OPTION => VALUE ... ]
3428
3429 Returns the label of the location object (see L<FS::cust_location>).
3430
3431 =cut
3432
3433 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
3434
3435 =item tax_locationnum
3436
3437 Returns the foreign key to a L<FS::cust_location> object for calculating
3438 tax on this package, as determined by the C<tax-pkg_address> and
3439 C<tax-ship_address> configuration flags.
3440
3441 =cut
3442
3443 sub tax_locationnum {
3444   my $self = shift;
3445   my $conf = FS::Conf->new;
3446   if ( $conf->exists('tax-pkg_address') ) {
3447     return $self->locationnum;
3448   }
3449   elsif ( $conf->exists('tax-ship_address') ) {
3450     return $self->cust_main->ship_locationnum;
3451   }
3452   else {
3453     return $self->cust_main->bill_locationnum;
3454   }
3455 }
3456
3457 =item tax_location
3458
3459 Returns the L<FS::cust_location> object for tax_locationnum.
3460
3461 =cut
3462
3463 sub tax_location {
3464   my $self = shift;
3465   my $conf = FS::Conf->new;
3466   if ( $conf->exists('tax-pkg_address') and $self->locationnum ) {
3467     return FS::cust_location->by_key($self->locationnum);
3468   }
3469   elsif ( $conf->exists('tax-ship_address') ) {
3470     return $self->cust_main->ship_location;
3471   }
3472   else {
3473     return $self->cust_main->bill_location;
3474   }
3475 }
3476
3477 =item seconds_since TIMESTAMP
3478
3479 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
3480 package have been online since TIMESTAMP, according to the session monitor.
3481
3482 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
3483 L<Time::Local> and L<Date::Parse> for conversion functions.
3484
3485 =cut
3486
3487 sub seconds_since {
3488   my($self, $since) = @_;
3489   my $seconds = 0;
3490
3491   foreach my $cust_svc (
3492     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
3493   ) {
3494     $seconds += $cust_svc->seconds_since($since);
3495   }
3496
3497   $seconds;
3498
3499 }
3500
3501 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
3502
3503 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
3504 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
3505 (exclusive).
3506
3507 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3508 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3509 functions.
3510
3511
3512 =cut
3513
3514 sub seconds_since_sqlradacct {
3515   my($self, $start, $end) = @_;
3516
3517   my $seconds = 0;
3518
3519   foreach my $cust_svc (
3520     grep {
3521       my $part_svc = $_->part_svc;
3522       $part_svc->svcdb eq 'svc_acct'
3523         && scalar($part_svc->part_export_usage);
3524     } $self->cust_svc
3525   ) {
3526     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
3527   }
3528
3529   $seconds;
3530
3531 }
3532
3533 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
3534
3535 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
3536 in this package for sessions ending between TIMESTAMP_START (inclusive) and
3537 TIMESTAMP_END
3538 (exclusive).
3539
3540 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3541 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3542 functions.
3543
3544 =cut
3545
3546 sub attribute_since_sqlradacct {
3547   my($self, $start, $end, $attrib) = @_;
3548
3549   my $sum = 0;
3550
3551   foreach my $cust_svc (
3552     grep {
3553       my $part_svc = $_->part_svc;
3554       scalar($part_svc->part_export_usage);
3555     } $self->cust_svc
3556   ) {
3557     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
3558   }
3559
3560   $sum;
3561
3562 }
3563
3564 =item quantity
3565
3566 =cut
3567
3568 sub quantity {
3569   my( $self, $value ) = @_;
3570   if ( defined($value) ) {
3571     $self->setfield('quantity', $value);
3572   }
3573   $self->getfield('quantity') || 1;
3574 }
3575
3576 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
3577
3578 Transfers as many services as possible from this package to another package.
3579
3580 The destination package can be specified by pkgnum by passing an FS::cust_pkg
3581 object.  The destination package must already exist.
3582
3583 Services are moved only if the destination allows services with the correct
3584 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
3585 this option with caution!  No provision is made for export differences
3586 between the old and new service definitions.  Probably only should be used
3587 when your exports for all service definitions of a given svcdb are identical.
3588 (attempt a transfer without it first, to move all possible svcpart-matching
3589 services)
3590
3591 Any services that can't be moved remain in the original package.
3592
3593 Returns an error, if there is one; otherwise, returns the number of services
3594 that couldn't be moved.
3595
3596 =cut
3597
3598 sub transfer {
3599   my ($self, $dest_pkgnum, %opt) = @_;
3600
3601   my $remaining = 0;
3602   my $dest;
3603   my %target;
3604
3605   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
3606     $dest = $dest_pkgnum;
3607     $dest_pkgnum = $dest->pkgnum;
3608   } else {
3609     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
3610   }
3611
3612   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
3613
3614   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
3615     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
3616   }
3617
3618   foreach my $cust_svc ($dest->cust_svc) {
3619     $target{$cust_svc->svcpart}--;
3620   }
3621
3622   my %svcpart2svcparts = ();
3623   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3624     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
3625     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
3626       next if exists $svcpart2svcparts{$svcpart};
3627       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
3628       $svcpart2svcparts{$svcpart} = [
3629         map  { $_->[0] }
3630         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
3631         map {
3632               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
3633                                                    'svcpart' => $_          } );
3634               [ $_,
3635                 $pkg_svc ? $pkg_svc->primary_svc : '',
3636                 $pkg_svc ? $pkg_svc->quantity : 0,
3637               ];
3638             }
3639
3640         grep { $_ != $svcpart }
3641         map  { $_->svcpart }
3642         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
3643       ];
3644       warn "alternates for svcpart $svcpart: ".
3645            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
3646         if $DEBUG;
3647     }
3648   }
3649
3650   my $error;
3651   foreach my $cust_svc ($self->cust_svc) {
3652     my $svcnum = $cust_svc->svcnum;
3653     if($target{$cust_svc->svcpart} > 0
3654        or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
3655       $target{$cust_svc->svcpart}--;
3656       my $new = new FS::cust_svc { $cust_svc->hash };
3657       $new->pkgnum($dest_pkgnum);
3658       $error = $new->replace($cust_svc);
3659     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3660       if ( $DEBUG ) {
3661         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
3662         warn "alternates to consider: ".
3663              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
3664       }
3665       my @alternate = grep {
3666                              warn "considering alternate svcpart $_: ".
3667                                   "$target{$_} available in new package\n"
3668                                if $DEBUG;
3669                              $target{$_} > 0;
3670                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
3671       if ( @alternate ) {
3672         warn "alternate(s) found\n" if $DEBUG;
3673         my $change_svcpart = $alternate[0];
3674         $target{$change_svcpart}--;
3675         my $new = new FS::cust_svc { $cust_svc->hash };
3676         $new->svcpart($change_svcpart);
3677         $new->pkgnum($dest_pkgnum);
3678         $error = $new->replace($cust_svc);
3679       } else {
3680         $remaining++;
3681       }
3682     } else {
3683       $remaining++
3684     }
3685     if ( $error ) {
3686       my @label = $cust_svc->label;
3687       return "service $label[1]: $error";
3688     }
3689   }
3690   return $remaining;
3691 }
3692
3693 =item grab_svcnums SVCNUM, SVCNUM ...
3694
3695 Change the pkgnum for the provided services to this packages.  If there is an
3696 error, returns the error, otherwise returns false.
3697
3698 =cut
3699
3700 sub grab_svcnums {
3701   my $self = shift;
3702   my @svcnum = @_;
3703
3704   local $SIG{HUP} = 'IGNORE';
3705   local $SIG{INT} = 'IGNORE';
3706   local $SIG{QUIT} = 'IGNORE';
3707   local $SIG{TERM} = 'IGNORE';
3708   local $SIG{TSTP} = 'IGNORE';
3709   local $SIG{PIPE} = 'IGNORE';
3710
3711   my $oldAutoCommit = $FS::UID::AutoCommit;
3712   local $FS::UID::AutoCommit = 0;
3713   my $dbh = dbh;
3714
3715   foreach my $svcnum (@svcnum) {
3716     my $cust_svc = qsearchs('cust_svc', { svcnum=>$svcnum } ) or do {
3717       $dbh->rollback if $oldAutoCommit;
3718       return "unknown svcnum $svcnum";
3719     };
3720     $cust_svc->pkgnum( $self->pkgnum );
3721     my $error = $cust_svc->replace;
3722     if ( $error ) {
3723       $dbh->rollback if $oldAutoCommit;
3724       return $error;
3725     }
3726   }
3727
3728   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3729   '';
3730
3731 }
3732
3733 =item reexport
3734
3735 This method is deprecated.  See the I<depend_jobnum> option to the insert and
3736 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
3737
3738 =cut
3739
3740 sub reexport {
3741   my $self = shift;
3742
3743   local $SIG{HUP} = 'IGNORE';
3744   local $SIG{INT} = 'IGNORE';
3745   local $SIG{QUIT} = 'IGNORE';
3746   local $SIG{TERM} = 'IGNORE';
3747   local $SIG{TSTP} = 'IGNORE';
3748   local $SIG{PIPE} = 'IGNORE';
3749
3750   my $oldAutoCommit = $FS::UID::AutoCommit;
3751   local $FS::UID::AutoCommit = 0;
3752   my $dbh = dbh;
3753
3754   foreach my $cust_svc ( $self->cust_svc ) {
3755     #false laziness w/svc_Common::insert
3756     my $svc_x = $cust_svc->svc_x;
3757     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
3758       my $error = $part_export->export_insert($svc_x);
3759       if ( $error ) {
3760         $dbh->rollback if $oldAutoCommit;
3761         return $error;
3762       }
3763     }
3764   }
3765
3766   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3767   '';
3768
3769 }
3770
3771 =item export_pkg_change OLD_CUST_PKG
3772
3773 Calls the "pkg_change" export action for all services attached to this package.
3774
3775 =cut
3776
3777 sub export_pkg_change {
3778   my( $self, $old )  = ( shift, shift );
3779
3780   local $SIG{HUP} = 'IGNORE';
3781   local $SIG{INT} = 'IGNORE';
3782   local $SIG{QUIT} = 'IGNORE';
3783   local $SIG{TERM} = 'IGNORE';
3784   local $SIG{TSTP} = 'IGNORE';
3785   local $SIG{PIPE} = 'IGNORE';
3786
3787   my $oldAutoCommit = $FS::UID::AutoCommit;
3788   local $FS::UID::AutoCommit = 0;
3789   my $dbh = dbh;
3790
3791   foreach my $svc_x ( map $_->svc_x, $self->cust_svc ) {
3792     my $error = $svc_x->export('pkg_change', $self, $old);
3793     if ( $error ) {
3794       $dbh->rollback if $oldAutoCommit;
3795       return $error;
3796     }
3797   }
3798
3799   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3800   '';
3801
3802 }
3803
3804 =item insert_reason
3805
3806 Associates this package with a (suspension or cancellation) reason (see
3807 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
3808 L<FS::reason>).
3809
3810 Available options are:
3811
3812 =over 4
3813
3814 =item reason
3815
3816 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.
3817
3818 =item reason_otaker
3819
3820 the access_user (see L<FS::access_user>) providing the reason
3821
3822 =item date
3823
3824 a unix timestamp
3825
3826 =item action
3827
3828 the action (cancel, susp, adjourn, expire) associated with the reason
3829
3830 =back
3831
3832 If there is an error, returns the error, otherwise returns false.
3833
3834 =cut
3835
3836 sub insert_reason {
3837   my ($self, %options) = @_;
3838
3839   my $otaker = $options{reason_otaker} ||
3840                $FS::CurrentUser::CurrentUser->username;
3841
3842   my $reasonnum;
3843   if ( $options{'reason'} =~ /^(\d+)$/ ) {
3844
3845     $reasonnum = $1;
3846
3847   } elsif ( ref($options{'reason'}) ) {
3848
3849     return 'Enter a new reason (or select an existing one)'
3850       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3851
3852     my $reason = new FS::reason({
3853       'reason_type' => $options{'reason'}->{'typenum'},
3854       'reason'      => $options{'reason'}->{'reason'},
3855     });
3856     my $error = $reason->insert;
3857     return $error if $error;
3858
3859     $reasonnum = $reason->reasonnum;
3860
3861   } else {
3862     return "Unparsable reason: ". $options{'reason'};
3863   }
3864
3865   my $cust_pkg_reason =
3866     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
3867                               'reasonnum' => $reasonnum,
3868                               'otaker'    => $otaker,
3869                               'action'    => substr(uc($options{'action'}),0,1),
3870                               'date'      => $options{'date'}
3871                                                ? $options{'date'}
3872                                                : time,
3873                             });
3874
3875   $cust_pkg_reason->insert;
3876 }
3877
3878 =item insert_discount
3879
3880 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
3881 inserting a new discount on the fly (see L<FS::discount>).
3882
3883 Available options are:
3884
3885 =over 4
3886
3887 =item discountnum
3888
3889 =back
3890
3891 If there is an error, returns the error, otherwise returns false.
3892
3893 =cut
3894
3895 sub insert_discount {
3896   #my ($self, %options) = @_;
3897   my $self = shift;
3898
3899   my $cust_pkg_discount = new FS::cust_pkg_discount {
3900     'pkgnum'      => $self->pkgnum,
3901     'discountnum' => $self->discountnum,
3902     'months_used' => 0,
3903     'end_date'    => '', #XXX
3904     #for the create a new discount case
3905     '_type'       => $self->discountnum__type,
3906     'amount'      => $self->discountnum_amount,
3907     'percent'     => $self->discountnum_percent,
3908     'months'      => $self->discountnum_months,
3909     'setup'      => $self->discountnum_setup,
3910     #'disabled'    => $self->discountnum_disabled,
3911   };
3912
3913   $cust_pkg_discount->insert;
3914 }
3915
3916 =item set_usage USAGE_VALUE_HASHREF
3917
3918 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3919 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3920 upbytes, downbytes, and totalbytes are appropriate keys.
3921
3922 All svc_accts which are part of this package have their values reset.
3923
3924 =cut
3925
3926 sub set_usage {
3927   my ($self, $valueref, %opt) = @_;
3928
3929   #only svc_acct can set_usage for now
3930   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3931     my $svc_x = $cust_svc->svc_x;
3932     $svc_x->set_usage($valueref, %opt)
3933       if $svc_x->can("set_usage");
3934   }
3935 }
3936
3937 =item recharge USAGE_VALUE_HASHREF
3938
3939 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3940 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3941 upbytes, downbytes, and totalbytes are appropriate keys.
3942
3943 All svc_accts which are part of this package have their values incremented.
3944
3945 =cut
3946
3947 sub recharge {
3948   my ($self, $valueref) = @_;
3949
3950   #only svc_acct can set_usage for now
3951   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3952     my $svc_x = $cust_svc->svc_x;
3953     $svc_x->recharge($valueref)
3954       if $svc_x->can("recharge");
3955   }
3956 }
3957
3958 =item cust_pkg_discount
3959
3960 =cut
3961
3962 sub cust_pkg_discount {
3963   my $self = shift;
3964   qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
3965 }
3966
3967 =item cust_pkg_discount_active
3968
3969 =cut
3970
3971 sub cust_pkg_discount_active {
3972   my $self = shift;
3973   grep { $_->status eq 'active' } $self->cust_pkg_discount;
3974 }
3975
3976 =item cust_pkg_usage
3977
3978 Returns a list of all voice usage counters attached to this package.
3979
3980 =cut
3981
3982 sub cust_pkg_usage {
3983   my $self = shift;
3984   qsearch('cust_pkg_usage', { pkgnum => $self->pkgnum });
3985 }
3986
3987 =item apply_usage OPTIONS
3988
3989 Takes the following options:
3990 - cdr: a call detail record (L<FS::cdr>)
3991 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
3992 - minutes: the maximum number of minutes to be charged
3993
3994 Finds available usage minutes for a call of this class, and subtracts
3995 up to that many minutes from the usage pool.  If the usage pool is empty,
3996 and the C<cdr-minutes_priority> global config option is set, minutes may
3997 be taken from other calls as well.  Either way, an allocation record will
3998 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
3999 number of minutes of usage applied to the call.
4000
4001 =cut
4002
4003 sub apply_usage {
4004   my ($self, %opt) = @_;
4005   my $cdr = $opt{cdr};
4006   my $rate_detail = $opt{rate_detail};
4007   my $minutes = $opt{minutes};
4008   my $classnum = $rate_detail->classnum;
4009   my $pkgnum = $self->pkgnum;
4010   my $custnum = $self->custnum;
4011
4012   local $SIG{HUP} = 'IGNORE';
4013   local $SIG{INT} = 'IGNORE';
4014   local $SIG{QUIT} = 'IGNORE';
4015   local $SIG{TERM} = 'IGNORE';
4016   local $SIG{TSTP} = 'IGNORE';
4017   local $SIG{PIPE} = 'IGNORE';
4018
4019   my $oldAutoCommit = $FS::UID::AutoCommit;
4020   local $FS::UID::AutoCommit = 0;
4021   my $dbh = dbh;
4022   my $order = FS::Conf->new->config('cdr-minutes_priority');
4023
4024   my $is_classnum;
4025   if ( $classnum ) {
4026     $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
4027   } else {
4028     $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
4029   }
4030   my @usage_recs = qsearch({
4031       'table'     => 'cust_pkg_usage',
4032       'addl_from' => ' JOIN part_pkg_usage       USING (pkgusagepart)'.
4033                      ' JOIN cust_pkg             USING (pkgnum)'.
4034                      ' JOIN part_pkg_usage_class USING (pkgusagepart)',
4035       'select'    => 'cust_pkg_usage.*',
4036       'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
4037                      " ( cust_pkg.custnum = $custnum AND ".
4038                      " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4039                      $is_classnum . ' AND '.
4040                      " cust_pkg_usage.minutes > 0",
4041       'order_by'  => " ORDER BY priority ASC",
4042   });
4043
4044   my $orig_minutes = $minutes;
4045   my $error;
4046   while (!$error and $minutes > 0 and @usage_recs) {
4047     my $cust_pkg_usage = shift @usage_recs;
4048     $cust_pkg_usage->select_for_update;
4049     my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
4050         pkgusagenum => $cust_pkg_usage->pkgusagenum,
4051         acctid      => $cdr->acctid,
4052         minutes     => min($cust_pkg_usage->minutes, $minutes),
4053     });
4054     $cust_pkg_usage->set('minutes',
4055       $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes
4056     );
4057     $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
4058     $minutes -= $cdr_cust_pkg_usage->minutes;
4059   }
4060   if ( $order and $minutes > 0 and !$error ) {
4061     # then try to steal minutes from another call
4062     my %search = (
4063         'table'     => 'cdr_cust_pkg_usage',
4064         'addl_from' => ' JOIN cust_pkg_usage        USING (pkgusagenum)'.
4065                        ' JOIN part_pkg_usage        USING (pkgusagepart)'.
4066                        ' JOIN cust_pkg              USING (pkgnum)'.
4067                        ' JOIN part_pkg_usage_class  USING (pkgusagepart)'.
4068                        ' JOIN cdr                   USING (acctid)',
4069         'select'    => 'cdr_cust_pkg_usage.*',
4070         'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
4071                        " ( cust_pkg.pkgnum = $pkgnum OR ".
4072                        " ( cust_pkg.custnum = $custnum AND ".
4073                        " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4074                        " part_pkg_usage_class.classnum = $classnum",
4075         'order_by'  => ' ORDER BY part_pkg_usage.priority ASC',
4076     );
4077     if ( $order eq 'time' ) {
4078       # find CDRs that are using minutes, but have a later startdate
4079       # than this call
4080       my $startdate = $cdr->startdate;
4081       if ($startdate !~ /^\d+$/) {
4082         die "bad cdr startdate '$startdate'";
4083       }
4084       $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
4085       # minimize needless reshuffling
4086       $search{'order_by'} .= ', cdr.startdate DESC';
4087     } else {
4088       # XXX may not work correctly with rate_time schedules.  Could
4089       # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
4090       # think...
4091       $search{'addl_from'} .=
4092         ' JOIN rate_detail'.
4093         ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
4094       if ( $order eq 'rate_high' ) {
4095         $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
4096                                 $rate_detail->min_charge;
4097         $search{'order_by'} .= ', rate_detail.min_charge ASC';
4098       } elsif ( $order eq 'rate_low' ) {
4099         $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
4100                                 $rate_detail->min_charge;
4101         $search{'order_by'} .= ', rate_detail.min_charge DESC';
4102       } else {
4103         #  this should really never happen
4104         die "invalid cdr-minutes_priority value '$order'\n";
4105       }
4106     }
4107     my @cdr_usage_recs = qsearch(\%search);
4108     my %reproc_cdrs;
4109     while (!$error and @cdr_usage_recs and $minutes > 0) {
4110       my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
4111       my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
4112       my $old_cdr = $cdr_cust_pkg_usage->cdr;
4113       $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
4114       $cdr_cust_pkg_usage->select_for_update;
4115       $old_cdr->select_for_update;
4116       $cust_pkg_usage->select_for_update;
4117       # in case someone else stole the usage from this CDR
4118       # while waiting for the lock...
4119       next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
4120       # steal the usage allocation and flag the old CDR for reprocessing
4121       $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
4122       # if the allocation is more minutes than we need, adjust it...
4123       my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
4124       if ( $delta > 0 ) {
4125         $cdr_cust_pkg_usage->set('minutes', $minutes);
4126         $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
4127         $error = $cust_pkg_usage->replace;
4128       }
4129       #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
4130       $error ||= $cdr_cust_pkg_usage->replace;
4131       # deduct the stolen minutes
4132       $minutes -= $cdr_cust_pkg_usage->minutes;
4133     }
4134     # after all minute-stealing is done, reset the affected CDRs
4135     foreach (values %reproc_cdrs) {
4136       $error ||= $_->set_status('');
4137       # XXX or should we just call $cdr->rate right here?
4138       # it's not like we can create a loop this way, since the min_charge
4139       # or call time has to go monotonically in one direction.
4140       # we COULD get some very deep recursions going, though...
4141     }
4142   } # if $order and $minutes
4143   if ( $error ) {
4144     $dbh->rollback;
4145     die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
4146   } else {
4147     $dbh->commit if $oldAutoCommit;
4148     return $orig_minutes - $minutes;
4149   }
4150 }
4151
4152 =item supplemental_pkgs
4153
4154 Returns a list of all packages supplemental to this one.
4155
4156 =cut
4157
4158 sub supplemental_pkgs {
4159   my $self = shift;
4160   qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
4161 }
4162
4163 =item main_pkg
4164
4165 Returns the package that this one is supplemental to, if any.
4166
4167 =cut
4168
4169 sub main_pkg {
4170   my $self = shift;
4171   if ( $self->main_pkgnum ) {
4172     return FS::cust_pkg->by_key($self->main_pkgnum);
4173   }
4174   return;
4175 }
4176
4177 =back
4178
4179 =head1 CLASS METHODS
4180
4181 =over 4
4182
4183 =item recurring_sql
4184
4185 Returns an SQL expression identifying recurring packages.
4186
4187 =cut
4188
4189 sub recurring_sql { "
4190   '0' != ( select freq from part_pkg
4191              where cust_pkg.pkgpart = part_pkg.pkgpart )
4192 "; }
4193
4194 =item onetime_sql
4195
4196 Returns an SQL expression identifying one-time packages.
4197
4198 =cut
4199
4200 sub onetime_sql { "
4201   '0' = ( select freq from part_pkg
4202             where cust_pkg.pkgpart = part_pkg.pkgpart )
4203 "; }
4204
4205 =item ordered_sql
4206
4207 Returns an SQL expression identifying ordered packages (recurring packages not
4208 yet billed).
4209
4210 =cut
4211
4212 sub ordered_sql {
4213    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
4214 }
4215
4216 =item active_sql
4217
4218 Returns an SQL expression identifying active packages.
4219
4220 =cut
4221
4222 sub active_sql {
4223   $_[0]->recurring_sql. "
4224   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4225   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4226   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4227 "; }
4228
4229 =item not_yet_billed_sql
4230
4231 Returns an SQL expression identifying packages which have not yet been billed.
4232
4233 =cut
4234
4235 sub not_yet_billed_sql { "
4236       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
4237   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4238   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4239 "; }
4240
4241 =item inactive_sql
4242
4243 Returns an SQL expression identifying inactive packages (one-time packages
4244 that are otherwise unsuspended/uncancelled).
4245
4246 =cut
4247
4248 sub inactive_sql { "
4249   ". $_[0]->onetime_sql(). "
4250   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4251   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4252   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4253 "; }
4254
4255 =item on_hold_sql
4256
4257 Returns an SQL expression identifying on-hold packages.
4258
4259 =cut
4260
4261 sub on_hold_sql {
4262   #$_[0]->recurring_sql(). ' AND '.
4263   "
4264         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel  = 0 )
4265     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp   != 0
4266     AND ( cust_pkg.setup  IS     NULL  OR cust_pkg.setup   = 0 )
4267   ";
4268 }
4269
4270 =item susp_sql
4271 =item suspended_sql
4272
4273 Returns an SQL expression identifying suspended packages.
4274
4275 =cut
4276
4277 sub suspended_sql { susp_sql(@_); }
4278 sub susp_sql {
4279   #$_[0]->recurring_sql(). ' AND '.
4280   "
4281         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
4282     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
4283     AND   cust_pkg.setup  IS NOT NULL AND cust_pkg.setup != 0
4284   ";
4285 }
4286
4287 =item cancel_sql
4288 =item cancelled_sql
4289
4290 Returns an SQL exprression identifying cancelled packages.
4291
4292 =cut
4293
4294 sub cancelled_sql { cancel_sql(@_); }
4295 sub cancel_sql {
4296   #$_[0]->recurring_sql(). ' AND '.
4297   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
4298 }
4299
4300 =item status_sql
4301
4302 Returns an SQL expression to give the package status as a string.
4303
4304 =cut
4305
4306 sub status_sql {
4307 "CASE
4308   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
4309   WHEN ( cust_pkg.susp IS NOT NULL AND cust_pkg.setup IS NULL ) THEN 'on hold'
4310   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
4311   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
4312   WHEN ".onetime_sql()." THEN 'one-time charge'
4313   ELSE 'active'
4314 END"
4315 }
4316
4317 =item search HASHREF
4318
4319 (Class method)
4320
4321 Returns a qsearch hash expression to search for parameters specified in HASHREF.
4322 Valid parameters are
4323
4324 =over 4
4325
4326 =item agentnum
4327
4328 =item magic
4329
4330 on hold, active, inactive (or one-time charge), suspended, cancel (or cancelled)
4331
4332 =item status
4333
4334 on hold, active, inactive (or one-time charge), suspended, cancel (or cancelled)
4335
4336 =item custom
4337
4338  boolean selects custom packages
4339
4340 =item classnum
4341
4342 =item pkgpart
4343
4344 pkgpart or arrayref or hashref of pkgparts
4345
4346 =item setup
4347
4348 arrayref of beginning and ending epoch date
4349
4350 =item last_bill
4351
4352 arrayref of beginning and ending epoch date
4353
4354 =item bill
4355
4356 arrayref of beginning and ending epoch date
4357
4358 =item adjourn
4359
4360 arrayref of beginning and ending epoch date
4361
4362 =item susp
4363
4364 arrayref of beginning and ending epoch date
4365
4366 =item expire
4367
4368 arrayref of beginning and ending epoch date
4369
4370 =item cancel
4371
4372 arrayref of beginning and ending epoch date
4373
4374 =item query
4375
4376 pkgnum or APKG_pkgnum
4377
4378 =item cust_fields
4379
4380 a value suited to passing to FS::UI::Web::cust_header
4381
4382 =item CurrentUser
4383
4384 specifies the user for agent virtualization
4385
4386 =item fcc_line
4387
4388 boolean; if true, returns only packages with more than 0 FCC phone lines.
4389
4390 =item state, country
4391
4392 Limit to packages with a service location in the specified state and country.
4393 For FCC 477 reporting, mostly.
4394
4395 =item location_cust
4396
4397 Limit to packages whose service locations are the same as the customer's
4398 default service location.
4399
4400 =item location_nocust
4401
4402 Limit to packages whose service locations are not the customer's default
4403 service location.
4404
4405 =item location_census
4406
4407 Limit to packages whose service locations have census tracts.
4408
4409 =item location_nocensus
4410
4411 Limit to packages whose service locations do not have a census tract.
4412
4413 =item location_geocode
4414
4415 Limit to packages whose locations have geocodes.
4416
4417 =item location_geocode
4418
4419 Limit to packages whose locations do not have geocodes.
4420
4421 =back
4422
4423 =cut
4424
4425 sub search {
4426   my ($class, $params) = @_;
4427   my @where = ();
4428
4429   ##
4430   # parse agent
4431   ##
4432
4433   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
4434     push @where,
4435       "cust_main.agentnum = $1";
4436   }
4437
4438   ##
4439   # parse cust_status
4440   ##
4441
4442   if ( $params->{'cust_status'} =~ /^([a-z]+)$/ ) {
4443     push @where, FS::cust_main->cust_status_sql . " = '$1' ";
4444   }
4445
4446   ##
4447   # parse customer sales person
4448   ##
4449
4450   if ( $params->{'cust_main_salesnum'} =~ /^(\d+)$/ ) {
4451     push @where, ($1 > 0) ? "cust_main.salesnum = $1"
4452                           : 'cust_main.salesnum IS NULL';
4453   }
4454
4455
4456   ##
4457   # parse sales person
4458   ##
4459
4460   if ( $params->{'salesnum'} =~ /^(\d+)$/ ) {
4461     push @where, ($1 > 0) ? "cust_pkg.salesnum = $1"
4462                           : 'cust_pkg.salesnum IS NULL';
4463   }
4464
4465   ##
4466   # parse custnum
4467   ##
4468
4469   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
4470     push @where,
4471       "cust_pkg.custnum = $1";
4472   }
4473
4474   ##
4475   # custbatch
4476   ##
4477
4478   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
4479     push @where,
4480       "cust_pkg.pkgbatch = '$1'";
4481   }
4482
4483   ##
4484   # parse status
4485   ##
4486
4487   if (    $params->{'magic'}  eq 'active'
4488        || $params->{'status'} eq 'active' ) {
4489
4490     push @where, FS::cust_pkg->active_sql();
4491
4492   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
4493             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
4494
4495     push @where, FS::cust_pkg->not_yet_billed_sql();
4496
4497   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
4498             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
4499
4500     push @where, FS::cust_pkg->inactive_sql();
4501
4502   } elsif (    $params->{'magic'}  =~ /^on[ _]hold$/
4503             || $params->{'status'} =~ /^on[ _]hold$/ ) {
4504
4505     push @where, FS::cust_pkg->on_hold_sql();
4506
4507
4508   } elsif (    $params->{'magic'}  eq 'suspended'
4509             || $params->{'status'} eq 'suspended'  ) {
4510
4511     push @where, FS::cust_pkg->suspended_sql();
4512
4513   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
4514             || $params->{'status'} =~ /^cancell?ed$/ ) {
4515
4516     push @where, FS::cust_pkg->cancelled_sql();
4517
4518   }
4519
4520   ###
4521   # parse package class
4522   ###
4523
4524   if ( exists($params->{'classnum'}) ) {
4525
4526     my @classnum = ();
4527     if ( ref($params->{'classnum'}) ) {
4528
4529       if ( ref($params->{'classnum'}) eq 'HASH' ) {
4530         @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
4531       } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
4532         @classnum = @{ $params->{'classnum'} };
4533       } else {
4534         die 'unhandled classnum ref '. $params->{'classnum'};
4535       }
4536
4537
4538     } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
4539       @classnum = ( $1 );
4540     }
4541
4542     if ( @classnum ) {
4543
4544       my @c_where = ();
4545       my @nums = grep $_, @classnum;
4546       push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
4547       my $null = scalar( grep { $_ eq '' } @classnum );
4548       push @c_where, 'part_pkg.classnum IS NULL' if $null;
4549
4550       if ( scalar(@c_where) == 1 ) {
4551         push @where, @c_where;
4552       } elsif ( @c_where ) {
4553         push @where, ' ( '. join(' OR ', @c_where). ' ) ';
4554       }
4555
4556     }
4557
4558
4559   }
4560
4561   ###
4562   # parse package report options
4563   ###
4564
4565   my @report_option = ();
4566   if ( exists($params->{'report_option'}) ) {
4567     if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
4568       @report_option = @{ $params->{'report_option'} };
4569     } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
4570       @report_option = split(',', $1);
4571     }
4572
4573   }
4574
4575   if (@report_option) {
4576     # this will result in the empty set for the dangling comma case as it should
4577     push @where,
4578       map{ "0 < ( SELECT count(*) FROM part_pkg_option
4579                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4580                     AND optionname = 'report_option_$_'
4581                     AND optionvalue = '1' )"
4582          } @report_option;
4583   }
4584
4585   foreach my $any ( grep /^report_option_any/, keys %$params ) {
4586
4587     my @report_option_any = ();
4588     if ( ref($params->{$any}) eq 'ARRAY' ) {
4589       @report_option_any = @{ $params->{$any} };
4590     } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
4591       @report_option_any = split(',', $1);
4592     }
4593
4594     if (@report_option_any) {
4595       # this will result in the empty set for the dangling comma case as it should
4596       push @where, ' ( '. join(' OR ',
4597         map{ "0 < ( SELECT count(*) FROM part_pkg_option
4598                       WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4599                       AND optionname = 'report_option_$_'
4600                       AND optionvalue = '1' )"
4601            } @report_option_any
4602       ). ' ) ';
4603     }
4604
4605   }
4606
4607   ###
4608   # parse custom
4609   ###
4610
4611   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
4612
4613   ###
4614   # parse fcc_line
4615   ###
4616
4617   push @where,  "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
4618                                                         if $params->{fcc_line};
4619
4620   ###
4621   # parse censustract
4622   ###
4623
4624   if ( exists($params->{'censustract'}) ) {
4625     $params->{'censustract'} =~ /^([.\d]*)$/;
4626     my $censustract = "cust_location.censustract = '$1'";
4627     $censustract .= ' OR cust_location.censustract is NULL' unless $1;
4628     push @where,  "( $censustract )";
4629   }
4630
4631   ###
4632   # parse censustract2
4633   ###
4634   if ( exists($params->{'censustract2'})
4635        && $params->{'censustract2'} =~ /^(\d*)$/
4636      )
4637   {
4638     if ($1) {
4639       push @where, "cust_location.censustract LIKE '$1%'";
4640     } else {
4641       push @where,
4642         "( cust_location.censustract = '' OR cust_location.censustract IS NULL )";
4643     }
4644   }
4645
4646   ###
4647   # parse country/state
4648   ###
4649   for (qw(state country)) { # parsing rules are the same for these
4650   if ( exists($params->{$_})
4651     && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
4652     {
4653       # XXX post-2.3 only--before that, state/country may be in cust_main
4654       push @where, "cust_location.$_ = '$1'";
4655     }
4656   }
4657
4658   ###
4659   # location_* flags
4660   ###
4661   if ( $params->{location_cust} xor $params->{location_nocust} ) {
4662     my $op = $params->{location_cust} ? '=' : '!=';
4663     push @where, "cust_location.locationnum $op cust_main.ship_locationnum";
4664   }
4665   if ( $params->{location_census} xor $params->{location_nocensus} ) {
4666     my $op = $params->{location_census} ? "IS NOT NULL" : "IS NULL";
4667     push @where, "cust_location.censustract $op";
4668   }
4669   if ( $params->{location_geocode} xor $params->{location_nogeocode} ) {
4670     my $op = $params->{location_geocode} ? "IS NOT NULL" : "IS NULL";
4671     push @where, "cust_location.geocode $op";
4672   }
4673
4674   ###
4675   # parse part_pkg
4676   ###
4677
4678   if ( ref($params->{'pkgpart'}) ) {
4679
4680     my @pkgpart = ();
4681     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
4682       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
4683     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
4684       @pkgpart = @{ $params->{'pkgpart'} };
4685     } else {
4686       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
4687     }
4688
4689     @pkgpart = grep /^(\d+)$/, @pkgpart;
4690
4691     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
4692
4693   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4694     push @where, "pkgpart = $1";
4695   }
4696
4697   ###
4698   # parse dates
4699   ###
4700
4701   my $orderby = '';
4702
4703   #false laziness w/report_cust_pkg.html
4704   my %disable = (
4705     'all'             => {},
4706     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
4707     'active'          => { 'susp'=>1, 'cancel'=>1 },
4708     'suspended'       => { 'cancel' => 1 },
4709     'cancelled'       => {},
4710     ''                => {},
4711   );
4712
4713   if( exists($params->{'active'} ) ) {
4714     # This overrides all the other date-related fields, and includes packages
4715     # that were active at some time during the interval.  It excludes:
4716     # - packages that were set up after the end of the interval
4717     # - packages that were canceled before the start of the interval
4718     # - packages that were suspended before the start of the interval
4719     #   and are still suspended now
4720     my($beginning, $ending) = @{$params->{'active'}};
4721     push @where,
4722       "cust_pkg.setup IS NOT NULL",
4723       "cust_pkg.setup <= $ending",
4724       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
4725       "(cust_pkg.susp   IS NULL OR cust_pkg.susp   >= $beginning )",
4726       "NOT (".FS::cust_pkg->onetime_sql . ")";
4727   }
4728   else {
4729     foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
4730
4731       next unless exists($params->{$field});
4732
4733       my($beginning, $ending) = @{$params->{$field}};
4734
4735       next if $beginning == 0 && $ending == 4294967295;
4736
4737       push @where,
4738         "cust_pkg.$field IS NOT NULL",
4739         "cust_pkg.$field >= $beginning",
4740         "cust_pkg.$field <= $ending";
4741
4742       $orderby ||= "ORDER BY cust_pkg.$field";
4743
4744     }
4745   }
4746
4747   $orderby ||= 'ORDER BY bill';
4748
4749   ###
4750   # parse magic, legacy, etc.
4751   ###
4752
4753   if ( $params->{'magic'} &&
4754        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
4755   ) {
4756
4757     $orderby = 'ORDER BY pkgnum';
4758
4759     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4760       push @where, "pkgpart = $1";
4761     }
4762
4763   } elsif ( $params->{'query'} eq 'pkgnum' ) {
4764
4765     $orderby = 'ORDER BY pkgnum';
4766
4767   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
4768
4769     $orderby = 'ORDER BY pkgnum';
4770
4771     push @where, '0 < (
4772       SELECT count(*) FROM pkg_svc
4773        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
4774          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
4775                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
4776                                      AND cust_svc.svcpart = pkg_svc.svcpart
4777                                 )
4778     )';
4779
4780   }
4781
4782   ##
4783   # setup queries, links, subs, etc. for the search
4784   ##
4785
4786   # here is the agent virtualization
4787   if ($params->{CurrentUser}) {
4788     my $access_user =
4789       qsearchs('access_user', { username => $params->{CurrentUser} });
4790
4791     if ($access_user) {
4792       push @where, $access_user->agentnums_sql('table'=>'cust_main');
4793     } else {
4794       push @where, "1=0";
4795     }
4796   } else {
4797     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
4798   }
4799
4800   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
4801
4802   my $addl_from = 'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
4803                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
4804                   'LEFT JOIN cust_location USING ( locationnum ) '.
4805                   FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg');
4806
4807   my $select;
4808   my $count_query;
4809   if ( $params->{'select_zip5'} ) {
4810     my $zip = 'cust_location.zip';
4811
4812     $select = "DISTINCT substr($zip,1,5) as zip";
4813     $orderby = "ORDER BY substr($zip,1,5)";
4814     $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
4815   } else {
4816     $select = join(', ',
4817                          'cust_pkg.*',
4818                          ( map "part_pkg.$_", qw( pkg freq ) ),
4819                          'pkg_class.classname',
4820                          'cust_main.custnum AS cust_main_custnum',
4821                          FS::UI::Web::cust_sql_fields(
4822                            $params->{'cust_fields'}
4823                          ),
4824                   );
4825     $count_query = 'SELECT COUNT(*)';
4826   }
4827
4828   $count_query .= " FROM cust_pkg $addl_from $extra_sql";
4829
4830   my $sql_query = {
4831     'table'       => 'cust_pkg',
4832     'hashref'     => {},
4833     'select'      => $select,
4834     'extra_sql'   => $extra_sql,
4835     'order_by'    => $orderby,
4836     'addl_from'   => $addl_from,
4837     'count_query' => $count_query,
4838   };
4839
4840 }
4841
4842 =item fcc_477_count
4843
4844 Returns a list of two package counts.  The first is a count of packages
4845 based on the supplied criteria and the second is the count of residential
4846 packages with those same criteria.  Criteria are specified as in the search
4847 method.
4848
4849 =cut
4850
4851 sub fcc_477_count {
4852   my ($class, $params) = @_;
4853
4854   my $sql_query = $class->search( $params );
4855
4856   my $count_sql = delete($sql_query->{'count_query'});
4857   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4858     or die "couldn't parse count_sql";
4859
4860   my $count_sth = dbh->prepare($count_sql)
4861     or die "Error preparing $count_sql: ". dbh->errstr;
4862   $count_sth->execute
4863     or die "Error executing $count_sql: ". $count_sth->errstr;
4864   my $count_arrayref = $count_sth->fetchrow_arrayref;
4865
4866   return ( @$count_arrayref );
4867
4868 }
4869
4870 =item tax_locationnum_sql
4871
4872 Returns an SQL expression for the tax location for a package, based
4873 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4874
4875 =cut
4876
4877 sub tax_locationnum_sql {
4878   my $conf = FS::Conf->new;
4879   if ( $conf->exists('tax-pkg_address') ) {
4880     'cust_pkg.locationnum';
4881   }
4882   elsif ( $conf->exists('tax-ship_address') ) {
4883     'cust_main.ship_locationnum';
4884   }
4885   else {
4886     'cust_main.bill_locationnum';
4887   }
4888 }
4889
4890 =item location_sql
4891
4892 Returns a list: the first item is an SQL fragment identifying matching
4893 packages/customers via location (taking into account shipping and package
4894 address taxation, if enabled), and subsequent items are the parameters to
4895 substitute for the placeholders in that fragment.
4896
4897 =cut
4898
4899 sub location_sql {
4900   my($class, %opt) = @_;
4901   my $ornull = $opt{'ornull'};
4902
4903   my $conf = new FS::Conf;
4904
4905   # '?' placeholders in _location_sql_where
4906   my $x = $ornull ? 3 : 2;
4907   my @bill_param = (
4908     ('district')x3,
4909     ('city')x3,
4910     ('county')x$x,
4911     ('state')x$x,
4912     'country'
4913   );
4914
4915   my $main_where;
4916   my @main_param;
4917   if ( $conf->exists('tax-ship_address') ) {
4918
4919     $main_where = "(
4920          (     ( ship_last IS NULL     OR  ship_last  = '' )
4921            AND ". _location_sql_where('cust_main', '', $ornull ). "
4922          )
4923       OR (       ship_last IS NOT NULL AND ship_last != ''
4924            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4925          )
4926     )";
4927     #    AND payby != 'COMP'
4928
4929     @main_param = ( @bill_param, @bill_param );
4930
4931   } else {
4932
4933     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4934     @main_param = @bill_param;
4935
4936   }
4937
4938   my $where;
4939   my @param;
4940   if ( $conf->exists('tax-pkg_address') ) {
4941
4942     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4943
4944     $where = " (
4945                     ( cust_pkg.locationnum IS     NULL AND $main_where )
4946                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
4947                )
4948              ";
4949     @param = ( @main_param, @bill_param );
4950
4951   } else {
4952
4953     $where = $main_where;
4954     @param = @main_param;
4955
4956   }
4957
4958   ( $where, @param );
4959
4960 }
4961
4962 #subroutine, helper for location_sql
4963 sub _location_sql_where {
4964   my $table  = shift;
4965   my $prefix = @_ ? shift : '';
4966   my $ornull = @_ ? shift : '';
4967
4968 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4969
4970   $ornull = $ornull ? ' OR ? IS NULL ' : '';
4971
4972   my $or_empty_city     = " OR ( ? = '' AND $table.${prefix}city     IS NULL )";
4973   my $or_empty_county   = " OR ( ? = '' AND $table.${prefix}county   IS NULL )";
4974   my $or_empty_state    = " OR ( ? = '' AND $table.${prefix}state    IS NULL )";
4975
4976   my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4977
4978 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
4979   "
4980         ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4981     AND ( $table.${prefix}city     = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4982     AND ( $table.${prefix}county   = ? $or_empty_county $ornull )
4983     AND ( $table.${prefix}state    = ? $or_empty_state  $ornull )
4984     AND   $table.${prefix}country  = ?
4985   ";
4986 }
4987
4988 sub _X_show_zero {
4989   my( $self, $what ) = @_;
4990
4991   my $what_show_zero = $what. '_show_zero';
4992   length($self->$what_show_zero())
4993     ? ($self->$what_show_zero() eq 'Y')
4994     : $self->part_pkg->$what_show_zero();
4995 }
4996
4997 =head1 SUBROUTINES
4998
4999 =over 4
5000
5001 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
5002
5003 CUSTNUM is a customer (see L<FS::cust_main>)
5004
5005 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
5006 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
5007 permitted.
5008
5009 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
5010 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
5011 new billing items.  An error is returned if this is not possible (see
5012 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
5013 parameter.
5014
5015 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
5016 newly-created cust_pkg objects.
5017
5018 REFNUM, if specified, will specify the FS::pkg_referral record to be created
5019 and inserted.  Multiple FS::pkg_referral records can be created by
5020 setting I<refnum> to an array reference of refnums or a hash reference with
5021 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
5022 record will be created corresponding to cust_main.refnum.
5023
5024 =cut
5025
5026 sub order {
5027   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
5028
5029   my $conf = new FS::Conf;
5030
5031   # Transactionize this whole mess
5032   local $SIG{HUP} = 'IGNORE';
5033   local $SIG{INT} = 'IGNORE';
5034   local $SIG{QUIT} = 'IGNORE';
5035   local $SIG{TERM} = 'IGNORE';
5036   local $SIG{TSTP} = 'IGNORE';
5037   local $SIG{PIPE} = 'IGNORE';
5038
5039   my $oldAutoCommit = $FS::UID::AutoCommit;
5040   local $FS::UID::AutoCommit = 0;
5041   my $dbh = dbh;
5042
5043   my $error;
5044 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
5045 #  return "Customer not found: $custnum" unless $cust_main;
5046
5047   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
5048     if $DEBUG;
5049
5050   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
5051                          @$remove_pkgnum;
5052
5053   my $change = scalar(@old_cust_pkg) != 0;
5054
5055   my %hash = ();
5056   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
5057
5058     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
5059          " to pkgpart ". $pkgparts->[0]. "\n"
5060       if $DEBUG;
5061
5062     my $err_or_cust_pkg =
5063       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
5064                                 'refnum'  => $refnum,
5065                               );
5066
5067     unless (ref($err_or_cust_pkg)) {
5068       $dbh->rollback if $oldAutoCommit;
5069       return $err_or_cust_pkg;
5070     }
5071
5072     push @$return_cust_pkg, $err_or_cust_pkg;
5073     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5074     return '';
5075
5076   }
5077
5078   # Create the new packages.
5079   foreach my $pkgpart (@$pkgparts) {
5080
5081     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
5082
5083     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
5084                                       pkgpart => $pkgpart,
5085                                       refnum  => $refnum,
5086                                       %hash,
5087                                     };
5088     $error = $cust_pkg->insert( 'change' => $change );
5089     push @$return_cust_pkg, $cust_pkg;
5090
5091     foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
5092       my $supp_pkg = FS::cust_pkg->new({
5093           custnum => $custnum,
5094           pkgpart => $link->dst_pkgpart,
5095           refnum  => $refnum,
5096           main_pkgnum => $cust_pkg->pkgnum,
5097           %hash,
5098       });
5099       $error ||= $supp_pkg->insert( 'change' => $change );
5100       push @$return_cust_pkg, $supp_pkg;
5101     }
5102
5103     if ($error) {
5104       $dbh->rollback if $oldAutoCommit;
5105       return $error;
5106     }
5107
5108   }
5109   # $return_cust_pkg now contains refs to all of the newly
5110   # created packages.
5111
5112   # Transfer services and cancel old packages.
5113   foreach my $old_pkg (@old_cust_pkg) {
5114
5115     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
5116       if $DEBUG;
5117
5118     foreach my $new_pkg (@$return_cust_pkg) {
5119       $error = $old_pkg->transfer($new_pkg);
5120       if ($error and $error == 0) {
5121         # $old_pkg->transfer failed.
5122         $dbh->rollback if $oldAutoCommit;
5123         return $error;
5124       }
5125     }
5126
5127     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
5128       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
5129       foreach my $new_pkg (@$return_cust_pkg) {
5130         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
5131         if ($error and $error == 0) {
5132           # $old_pkg->transfer failed.
5133         $dbh->rollback if $oldAutoCommit;
5134         return $error;
5135         }
5136       }
5137     }
5138
5139     if ($error > 0) {
5140       # Transfers were successful, but we went through all of the
5141       # new packages and still had services left on the old package.
5142       # We can't cancel the package under the circumstances, so abort.
5143       $dbh->rollback if $oldAutoCommit;
5144       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
5145     }
5146     $error = $old_pkg->cancel( quiet=>1 );
5147     if ($error) {
5148       $dbh->rollback;
5149       return $error;
5150     }
5151   }
5152   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5153   '';
5154 }
5155
5156 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
5157
5158 A bulk change method to change packages for multiple customers.
5159
5160 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
5161 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
5162 permitted.
5163
5164 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
5165 replace.  The services (see L<FS::cust_svc>) are moved to the
5166 new billing items.  An error is returned if this is not possible (see
5167 L<FS::pkg_svc>).
5168
5169 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
5170 newly-created cust_pkg objects.
5171
5172 =cut
5173
5174 sub bulk_change {
5175   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
5176
5177   # Transactionize this whole mess
5178   local $SIG{HUP} = 'IGNORE';
5179   local $SIG{INT} = 'IGNORE';
5180   local $SIG{QUIT} = 'IGNORE';
5181   local $SIG{TERM} = 'IGNORE';
5182   local $SIG{TSTP} = 'IGNORE';
5183   local $SIG{PIPE} = 'IGNORE';
5184
5185   my $oldAutoCommit = $FS::UID::AutoCommit;
5186   local $FS::UID::AutoCommit = 0;
5187   my $dbh = dbh;
5188
5189   my @errors;
5190   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
5191                          @$remove_pkgnum;
5192
5193   while(scalar(@old_cust_pkg)) {
5194     my @return = ();
5195     my $custnum = $old_cust_pkg[0]->custnum;
5196     my (@remove) = map { $_->pkgnum }
5197                    grep { $_->custnum == $custnum } @old_cust_pkg;
5198     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
5199
5200     my $error = order $custnum, $pkgparts, \@remove, \@return;
5201
5202     push @errors, $error
5203       if $error;
5204     push @$return_cust_pkg, @return;
5205   }
5206
5207   if (scalar(@errors)) {
5208     $dbh->rollback if $oldAutoCommit;
5209     return join(' / ', @errors);
5210   }
5211
5212   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5213   '';
5214 }
5215
5216 # Used by FS::Upgrade to migrate to a new database.
5217 sub _upgrade_data {  # class method
5218   my ($class, %opts) = @_;
5219   $class->_upgrade_otaker(%opts);
5220   my @statements = (
5221     # RT#10139, bug resulting in contract_end being set when it shouldn't
5222   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
5223     # RT#10830, bad calculation of prorate date near end of year
5224     # the date range for bill is December 2009, and we move it forward
5225     # one year if it's before the previous bill date (which it should
5226     # never be)
5227   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
5228   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
5229   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
5230     # RT6628, add order_date to cust_pkg
5231     'update cust_pkg set order_date = (select history_date from h_cust_pkg
5232         where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
5233         history_action = \'insert\') where order_date is null',
5234   );
5235   foreach my $sql (@statements) {
5236     my $sth = dbh->prepare($sql);
5237     $sth->execute or die $sth->errstr;
5238   }
5239 }
5240
5241 =back
5242
5243 =head1 BUGS
5244
5245 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
5246
5247 In sub order, the @pkgparts array (passed by reference) is clobbered.
5248
5249 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
5250 method to pass dates to the recur_prog expression, it should do so.
5251
5252 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
5253 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
5254 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
5255 configuration values.  Probably need a subroutine which decides what to do
5256 based on whether or not we've fetched the user yet, rather than a hash.  See
5257 FS::UID and the TODO.
5258
5259 Now that things are transactional should the check in the insert method be
5260 moved to check ?
5261
5262 =head1 SEE ALSO
5263
5264 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
5265 L<FS::pkg_svc>, schema.html from the base documentation
5266
5267 =cut
5268
5269 1;
5270