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