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