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