FS/FS/cust_pkg.pm

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