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 "creating location record: $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 customer record: $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 "inserting new package: $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 "transferring $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 "converting $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";
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 "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 "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 "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 "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 "canceling old package: $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 "billing new package: $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     my $svcnum = $cust_svc->svcnum;
3546     if($target{$cust_svc->svcpart} > 0
3547        or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
3548       $target{$cust_svc->svcpart}--;
3549       my $new = new FS::cust_svc { $cust_svc->hash };
3550       $new->pkgnum($dest_pkgnum);
3551       my $error = $new->replace($cust_svc);
3552       return "svcnum $svcnum: $error" if $error;
3553     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3554       if ( $DEBUG ) {
3555         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
3556         warn "alternates to consider: ".
3557              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
3558       }
3559       my @alternate = grep {
3560                              warn "considering alternate svcpart $_: ".
3561                                   "$target{$_} available in new package\n"
3562                                if $DEBUG;
3563                              $target{$_} > 0;
3564                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
3565       if ( @alternate ) {
3566         warn "alternate(s) found\n" if $DEBUG;
3567         my $change_svcpart = $alternate[0];
3568         $target{$change_svcpart}--;
3569         my $new = new FS::cust_svc { $cust_svc->hash };
3570         $new->svcpart($change_svcpart);
3571         $new->pkgnum($dest_pkgnum);
3572         my $error = $new->replace($cust_svc);
3573         return "svcnum $svcnum: $error" if $error;
3574       } else {
3575         $remaining++;
3576       }
3577     } else {
3578       $remaining++
3579     }
3580   }
3581   return $remaining;
3582 }
3583
3584 =item grab_svcnums SVCNUM, SVCNUM ...
3585
3586 Change the pkgnum for the provided services to this packages.  If there is an
3587 error, returns the error, otherwise returns false.
3588
3589 =cut
3590
3591 sub grab_svcnums {
3592   my $self = shift;
3593   my @svcnum = @_;
3594
3595   my $oldAutoCommit = $FS::UID::AutoCommit;
3596   local $FS::UID::AutoCommit = 0;
3597   my $dbh = dbh;
3598
3599   foreach my $svcnum (@svcnum) {
3600     my $cust_svc = qsearchs('cust_svc', { svcnum=>$svcnum } ) or do {
3601       $dbh->rollback if $oldAutoCommit;
3602       return "unknown svcnum $svcnum";
3603     };
3604     $cust_svc->pkgnum( $self->pkgnum );
3605     my $error = $cust_svc->replace;
3606     if ( $error ) {
3607       $dbh->rollback if $oldAutoCommit;
3608       return $error;
3609     }
3610   }
3611
3612   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3613   '';
3614
3615 }
3616
3617 =item reexport
3618
3619 This method is deprecated.  See the I<depend_jobnum> option to the insert and
3620 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
3621
3622 =cut
3623
3624 #looks like this is still used by the order_pkg and change_pkg methods in
3625 # ClientAPI/MyAccount, need to look into those before removing
3626 sub reexport {
3627   my $self = shift;
3628
3629   my $oldAutoCommit = $FS::UID::AutoCommit;
3630   local $FS::UID::AutoCommit = 0;
3631   my $dbh = dbh;
3632
3633   foreach my $cust_svc ( $self->cust_svc ) {
3634     #false laziness w/svc_Common::insert
3635     my $svc_x = $cust_svc->svc_x;
3636     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
3637       my $error = $part_export->export_insert($svc_x);
3638       if ( $error ) {
3639         $dbh->rollback if $oldAutoCommit;
3640         return $error;
3641       }
3642     }
3643   }
3644
3645   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3646   '';
3647
3648 }
3649
3650 =item export_pkg_change OLD_CUST_PKG
3651
3652 Calls the "pkg_change" export action for all services attached to this package.
3653
3654 =cut
3655
3656 sub export_pkg_change {
3657   my( $self, $old )  = ( shift, shift );
3658
3659   my $oldAutoCommit = $FS::UID::AutoCommit;
3660   local $FS::UID::AutoCommit = 0;
3661   my $dbh = dbh;
3662
3663   foreach my $svc_x ( map $_->svc_x, $self->cust_svc ) {
3664     my $error = $svc_x->export('pkg_change', $self, $old);
3665     if ( $error ) {
3666       $dbh->rollback if $oldAutoCommit;
3667       return $error;
3668     }
3669   }
3670
3671   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3672   '';
3673
3674 }
3675
3676 =item insert_reason
3677
3678 Associates this package with a (suspension or cancellation) reason (see
3679 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
3680 L<FS::reason>).
3681
3682 Available options are:
3683
3684 =over 4
3685
3686 =item reason
3687
3688 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.
3689
3690 =item reason_otaker
3691
3692 the access_user (see L<FS::access_user>) providing the reason
3693
3694 =item date
3695
3696 a unix timestamp
3697
3698 =item action
3699
3700 the action (cancel, susp, adjourn, expire) associated with the reason
3701
3702 =back
3703
3704 If there is an error, returns the error, otherwise returns false.
3705
3706 =cut
3707
3708 sub insert_reason {
3709   my ($self, %options) = @_;
3710
3711   my $otaker = $options{reason_otaker} ||
3712                $FS::CurrentUser::CurrentUser->username;
3713
3714   my $reasonnum;
3715   if ( $options{'reason'} =~ /^(\d+)$/ ) {
3716
3717     $reasonnum = $1;
3718
3719   } elsif ( ref($options{'reason'}) ) {
3720
3721     return 'Enter a new reason (or select an existing one)'
3722       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3723
3724     my $reason = new FS::reason({
3725       'reason_type' => $options{'reason'}->{'typenum'},
3726       'reason'      => $options{'reason'}->{'reason'},
3727     });
3728     my $error = $reason->insert;
3729     return $error if $error;
3730
3731     $reasonnum = $reason->reasonnum;
3732
3733   } else {
3734     return "Unparsable reason: ". $options{'reason'};
3735   }
3736
3737   my $cust_pkg_reason =
3738     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
3739                               'reasonnum' => $reasonnum,
3740                               'otaker'    => $otaker,
3741                               'action'    => substr(uc($options{'action'}),0,1),
3742                               'date'      => $options{'date'}
3743                                                ? $options{'date'}
3744                                                : time,
3745                             });
3746
3747   $cust_pkg_reason->insert;
3748 }
3749
3750 =item insert_discount
3751
3752 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
3753 inserting a new discount on the fly (see L<FS::discount>).
3754
3755 Available options are:
3756
3757 =over 4
3758
3759 =item discountnum
3760
3761 =back
3762
3763 If there is an error, returns the error, otherwise returns false.
3764
3765 =cut
3766
3767 sub insert_discount {
3768   #my ($self, %options) = @_;
3769   my $self = shift;
3770
3771   my $cust_pkg_discount = new FS::cust_pkg_discount {
3772     'pkgnum'      => $self->pkgnum,
3773     'discountnum' => $self->discountnum,
3774     'months_used' => 0,
3775     'end_date'    => '', #XXX
3776     #for the create a new discount case
3777     '_type'       => $self->discountnum__type,
3778     'amount'      => $self->discountnum_amount,
3779     'percent'     => $self->discountnum_percent,
3780     'months'      => $self->discountnum_months,
3781     'setup'      => $self->discountnum_setup,
3782     #'disabled'    => $self->discountnum_disabled,
3783   };
3784
3785   $cust_pkg_discount->insert;
3786 }
3787
3788 =item set_usage USAGE_VALUE_HASHREF
3789
3790 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3791 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3792 upbytes, downbytes, and totalbytes are appropriate keys.
3793
3794 All svc_accts which are part of this package have their values reset.
3795
3796 =cut
3797
3798 sub set_usage {
3799   my ($self, $valueref, %opt) = @_;
3800
3801   #only svc_acct can set_usage for now
3802   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3803     my $svc_x = $cust_svc->svc_x;
3804     $svc_x->set_usage($valueref, %opt)
3805       if $svc_x->can("set_usage");
3806   }
3807 }
3808
3809 =item recharge USAGE_VALUE_HASHREF
3810
3811 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3812 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3813 upbytes, downbytes, and totalbytes are appropriate keys.
3814
3815 All svc_accts which are part of this package have their values incremented.
3816
3817 =cut
3818
3819 sub recharge {
3820   my ($self, $valueref) = @_;
3821
3822   #only svc_acct can set_usage for now
3823   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3824     my $svc_x = $cust_svc->svc_x;
3825     $svc_x->recharge($valueref)
3826       if $svc_x->can("recharge");
3827   }
3828 }
3829
3830 =item apply_usageprice
3831
3832 =cut
3833
3834 sub apply_usageprice {
3835   my $self = shift;
3836
3837   my $oldAutoCommit = $FS::UID::AutoCommit;
3838   local $FS::UID::AutoCommit = 0;
3839   my $dbh = dbh;
3840
3841   my $error = '';
3842
3843   foreach my $cust_pkg_usageprice ( $self->cust_pkg_usageprice ) {
3844     $error ||= $cust_pkg_usageprice->apply;
3845   }
3846
3847   if ( $error ) {
3848     $dbh->rollback if $oldAutoCommit;
3849     die "error applying part_pkg_usageprice add-ons, pkgnum ". $self->pkgnum.
3850         ": $error\n";
3851   } else {
3852     $dbh->commit if $oldAutoCommit;
3853   }
3854
3855
3856 }
3857
3858 =item cust_pkg_discount
3859
3860 =item cust_pkg_discount_active
3861
3862 =cut
3863
3864 sub cust_pkg_discount_active {
3865   my $self = shift;
3866   grep { $_->status eq 'active' } $self->cust_pkg_discount;
3867 }
3868
3869 =item cust_pkg_usage
3870
3871 Returns a list of all voice usage counters attached to this package.
3872
3873 =item apply_usage OPTIONS
3874
3875 Takes the following options:
3876 - cdr: a call detail record (L<FS::cdr>)
3877 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
3878 - minutes: the maximum number of minutes to be charged
3879
3880 Finds available usage minutes for a call of this class, and subtracts
3881 up to that many minutes from the usage pool.  If the usage pool is empty,
3882 and the C<cdr-minutes_priority> global config option is set, minutes may
3883 be taken from other calls as well.  Either way, an allocation record will
3884 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
3885 number of minutes of usage applied to the call.
3886
3887 =cut
3888
3889 sub apply_usage {
3890   my ($self, %opt) = @_;
3891   my $cdr = $opt{cdr};
3892   my $rate_detail = $opt{rate_detail};
3893   my $minutes = $opt{minutes};
3894   my $classnum = $rate_detail->classnum;
3895   my $pkgnum = $self->pkgnum;
3896   my $custnum = $self->custnum;
3897
3898   my $oldAutoCommit = $FS::UID::AutoCommit;
3899   local $FS::UID::AutoCommit = 0;
3900   my $dbh = dbh;
3901
3902   my $order = FS::Conf->new->config('cdr-minutes_priority');
3903
3904   my $is_classnum;
3905   if ( $classnum ) {
3906     $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
3907   } else {
3908     $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
3909   }
3910   my @usage_recs = qsearch({
3911       'table'     => 'cust_pkg_usage',
3912       'addl_from' => ' JOIN part_pkg_usage       USING (pkgusagepart)'.
3913                      ' JOIN cust_pkg             USING (pkgnum)'.
3914                      ' JOIN part_pkg_usage_class USING (pkgusagepart)',
3915       'select'    => 'cust_pkg_usage.*',
3916       'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
3917                      " ( cust_pkg.custnum = $custnum AND ".
3918                      " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3919                      $is_classnum . ' AND '.
3920                      " cust_pkg_usage.minutes > 0",
3921       'order_by'  => " ORDER BY priority ASC",
3922   });
3923
3924   my $orig_minutes = $minutes;
3925   my $error;
3926   while (!$error and $minutes > 0 and @usage_recs) {
3927     my $cust_pkg_usage = shift @usage_recs;
3928     $cust_pkg_usage->select_for_update;
3929     my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
3930         pkgusagenum => $cust_pkg_usage->pkgusagenum,
3931         acctid      => $cdr->acctid,
3932         minutes     => min($cust_pkg_usage->minutes, $minutes),
3933     });
3934     $cust_pkg_usage->set('minutes',
3935       sprintf('%.0f', $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes)
3936     );
3937     $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
3938     $minutes -= $cdr_cust_pkg_usage->minutes;
3939   }
3940   if ( $order and $minutes > 0 and !$error ) {
3941     # then try to steal minutes from another call
3942     my %search = (
3943         'table'     => 'cdr_cust_pkg_usage',
3944         'addl_from' => ' JOIN cust_pkg_usage        USING (pkgusagenum)'.
3945                        ' JOIN part_pkg_usage        USING (pkgusagepart)'.
3946                        ' JOIN cust_pkg              USING (pkgnum)'.
3947                        ' JOIN part_pkg_usage_class  USING (pkgusagepart)'.
3948                        ' JOIN cdr                   USING (acctid)',
3949         'select'    => 'cdr_cust_pkg_usage.*',
3950         'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
3951                        " ( cust_pkg.pkgnum = $pkgnum OR ".
3952                        " ( cust_pkg.custnum = $custnum AND ".
3953                        " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3954                        " part_pkg_usage_class.classnum = $classnum",
3955         'order_by'  => ' ORDER BY part_pkg_usage.priority ASC',
3956     );
3957     if ( $order eq 'time' ) {
3958       # find CDRs that are using minutes, but have a later startdate
3959       # than this call
3960       my $startdate = $cdr->startdate;
3961       if ($startdate !~ /^\d+$/) {
3962         die "bad cdr startdate '$startdate'";
3963       }
3964       $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
3965       # minimize needless reshuffling
3966       $search{'order_by'} .= ', cdr.startdate DESC';
3967     } else {
3968       # XXX may not work correctly with rate_time schedules.  Could
3969       # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
3970       # think...
3971       $search{'addl_from'} .=
3972         ' JOIN rate_detail'.
3973         ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
3974       if ( $order eq 'rate_high' ) {
3975         $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
3976                                 $rate_detail->min_charge;
3977         $search{'order_by'} .= ', rate_detail.min_charge ASC';
3978       } elsif ( $order eq 'rate_low' ) {
3979         $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
3980                                 $rate_detail->min_charge;
3981         $search{'order_by'} .= ', rate_detail.min_charge DESC';
3982       } else {
3983         #  this should really never happen
3984         die "invalid cdr-minutes_priority value '$order'\n";
3985       }
3986     }
3987     my @cdr_usage_recs = qsearch(\%search);
3988     my %reproc_cdrs;
3989     while (!$error and @cdr_usage_recs and $minutes > 0) {
3990       my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
3991       my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
3992       my $old_cdr = $cdr_cust_pkg_usage->cdr;
3993       $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
3994       $cdr_cust_pkg_usage->select_for_update;
3995       $old_cdr->select_for_update;
3996       $cust_pkg_usage->select_for_update;
3997       # in case someone else stole the usage from this CDR
3998       # while waiting for the lock...
3999       next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
4000       # steal the usage allocation and flag the old CDR for reprocessing
4001       $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
4002       # if the allocation is more minutes than we need, adjust it...
4003       my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
4004       if ( $delta > 0 ) {
4005         $cdr_cust_pkg_usage->set('minutes', $minutes);
4006         $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
4007         $error = $cust_pkg_usage->replace;
4008       }
4009       #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
4010       $error ||= $cdr_cust_pkg_usage->replace;
4011       # deduct the stolen minutes
4012       $minutes -= $cdr_cust_pkg_usage->minutes;
4013     }
4014     # after all minute-stealing is done, reset the affected CDRs
4015     foreach (values %reproc_cdrs) {
4016       $error ||= $_->set_status('');
4017       # XXX or should we just call $cdr->rate right here?
4018       # it's not like we can create a loop this way, since the min_charge
4019       # or call time has to go monotonically in one direction.
4020       # we COULD get some very deep recursions going, though...
4021     }
4022   } # if $order and $minutes
4023   if ( $error ) {
4024     $dbh->rollback;
4025     die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
4026   } else {
4027     $dbh->commit if $oldAutoCommit;
4028     return $orig_minutes - $minutes;
4029   }
4030 }
4031
4032 =item supplemental_pkgs
4033
4034 Returns a list of all packages supplemental to this one.
4035
4036 =cut
4037
4038 sub supplemental_pkgs {
4039   my $self = shift;
4040   qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
4041 }
4042
4043 =item main_pkg
4044
4045 Returns the package that this one is supplemental to, if any.
4046
4047 =cut
4048
4049 sub main_pkg {
4050   my $self = shift;
4051   if ( $self->main_pkgnum ) {
4052     return FS::cust_pkg->by_key($self->main_pkgnum);
4053   }
4054   return;
4055 }
4056
4057 =back
4058
4059 =head1 CLASS METHODS
4060
4061 =over 4
4062
4063 =item recurring_sql
4064
4065 Returns an SQL expression identifying recurring packages.
4066
4067 =cut
4068
4069 sub recurring_sql { "
4070   '0' != ( select freq from part_pkg
4071              where cust_pkg.pkgpart = part_pkg.pkgpart )
4072 "; }
4073
4074 =item onetime_sql
4075
4076 Returns an SQL expression identifying one-time packages.
4077
4078 =cut
4079
4080 sub onetime_sql { "
4081   '0' = ( select freq from part_pkg
4082             where cust_pkg.pkgpart = part_pkg.pkgpart )
4083 "; }
4084
4085 =item ordered_sql
4086
4087 Returns an SQL expression identifying ordered packages (recurring packages not
4088 yet billed).
4089
4090 =cut
4091
4092 sub ordered_sql {
4093    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
4094 }
4095
4096 =item active_sql
4097
4098 Returns an SQL expression identifying active packages.
4099
4100 =cut
4101
4102 sub active_sql {
4103   $_[0]->recurring_sql. "
4104   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4105   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4106   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4107 "; }
4108
4109 =item not_yet_billed_sql
4110
4111 Returns an SQL expression identifying packages which have not yet been billed.
4112
4113 =cut
4114
4115 sub not_yet_billed_sql { "
4116       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
4117   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4118   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4119 "; }
4120
4121 =item inactive_sql
4122
4123 Returns an SQL expression identifying inactive packages (one-time packages
4124 that are otherwise unsuspended/uncancelled).
4125
4126 =cut
4127
4128 sub inactive_sql { "
4129   ". $_[0]->onetime_sql(). "
4130   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4131   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4132   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4133 "; }
4134
4135 =item susp_sql
4136 =item suspended_sql
4137
4138 Returns an SQL expression identifying suspended packages.
4139
4140 =cut
4141
4142 sub suspended_sql { susp_sql(@_); }
4143 sub susp_sql {
4144   #$_[0]->recurring_sql(). ' AND '.
4145   "
4146         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
4147     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
4148   ";
4149 }
4150
4151 =item cancel_sql
4152 =item cancelled_sql
4153
4154 Returns an SQL exprression identifying cancelled packages.
4155
4156 =cut
4157
4158 sub cancelled_sql { cancel_sql(@_); }
4159 sub cancel_sql {
4160   #$_[0]->recurring_sql(). ' AND '.
4161   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
4162 }
4163
4164 =item status_sql
4165
4166 Returns an SQL expression to give the package status as a string.
4167
4168 =cut
4169
4170 sub status_sql {
4171 "CASE
4172   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
4173   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
4174   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
4175   WHEN ".onetime_sql()." THEN 'one-time charge'
4176   ELSE 'active'
4177 END"
4178 }
4179
4180 =item search HASHREF
4181
4182 (Class method)
4183
4184 Returns a qsearch hash expression to search for parameters specified in HASHREF.
4185 Valid parameters are
4186
4187 =over 4
4188
4189 =item agentnum
4190
4191 =item magic
4192
4193 active, inactive, suspended, cancel (or cancelled)
4194
4195 =item status
4196
4197 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
4198
4199 =item custom
4200
4201  boolean selects custom packages
4202
4203 =item classnum
4204
4205 =item pkgpart
4206
4207 pkgpart or arrayref or hashref of pkgparts
4208
4209 =item setup
4210
4211 arrayref of beginning and ending epoch date
4212
4213 =item last_bill
4214
4215 arrayref of beginning and ending epoch date
4216
4217 =item bill
4218
4219 arrayref of beginning and ending epoch date
4220
4221 =item adjourn
4222
4223 arrayref of beginning and ending epoch date
4224
4225 =item susp
4226
4227 arrayref of beginning and ending epoch date
4228
4229 =item expire
4230
4231 arrayref of beginning and ending epoch date
4232
4233 =item cancel
4234
4235 arrayref of beginning and ending epoch date
4236
4237 =item query
4238
4239 pkgnum or APKG_pkgnum
4240
4241 =item cust_fields
4242
4243 a value suited to passing to FS::UI::Web::cust_header
4244
4245 =item CurrentUser
4246
4247 specifies the user for agent virtualization
4248
4249 =item fcc_line
4250
4251 boolean; if true, returns only packages with more than 0 FCC phone lines.
4252
4253 =item state, country
4254
4255 Limit to packages with a service location in the specified state and country.
4256 For FCC 477 reporting, mostly.
4257
4258 =item location_cust
4259
4260 Limit to packages whose service locations are the same as the customer's
4261 default service location.
4262
4263 =item location_nocust
4264
4265 Limit to packages whose service locations are not the customer's default
4266 service location.
4267
4268 =item location_census
4269
4270 Limit to packages whose service locations have census tracts.
4271
4272 =item location_nocensus
4273
4274 Limit to packages whose service locations do not have a census tract.
4275
4276 =item location_geocode
4277
4278 Limit to packages whose locations have geocodes.
4279
4280 =item location_geocode
4281
4282 Limit to packages whose locations do not have geocodes.
4283
4284 =back
4285
4286 =cut
4287
4288 sub search {
4289   my ($class, $params) = @_;
4290   my @where = ();
4291
4292   ##
4293   # parse agent
4294   ##
4295
4296   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
4297     push @where,
4298       "cust_main.agentnum = $1";
4299   }
4300
4301   ##
4302   # parse cust_status
4303   ##
4304
4305   if ( $params->{'cust_status'} =~ /^([a-z]+)$/ ) {
4306     push @where, FS::cust_main->cust_status_sql . " = '$1' ";
4307   }
4308
4309   ##
4310   # parse customer sales person
4311   ##
4312
4313   if ( $params->{'cust_main_salesnum'} =~ /^(\d+)$/ ) {
4314     push @where, ($1 > 0) ? "cust_main.salesnum = $1"
4315                           : 'cust_main.salesnum IS NULL';
4316   }
4317
4318
4319   ##
4320   # parse sales person
4321   ##
4322
4323   if ( $params->{'salesnum'} =~ /^(\d+)$/ ) {
4324     push @where, ($1 > 0) ? "cust_pkg.salesnum = $1"
4325                           : 'cust_pkg.salesnum IS NULL';
4326   }
4327
4328   ##
4329   # parse custnum
4330   ##
4331
4332   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
4333     push @where,
4334       "cust_pkg.custnum = $1";
4335   }
4336
4337   ##
4338   # custbatch
4339   ##
4340
4341   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
4342     push @where,
4343       "cust_pkg.pkgbatch = '$1'";
4344   }
4345
4346   ##
4347   # parse status
4348   ##
4349
4350   if (    $params->{'magic'}  eq 'active'
4351        || $params->{'status'} eq 'active' ) {
4352
4353     push @where, FS::cust_pkg->active_sql();
4354
4355   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
4356             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
4357
4358     push @where, FS::cust_pkg->not_yet_billed_sql();
4359
4360   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
4361             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
4362
4363     push @where, FS::cust_pkg->inactive_sql();
4364
4365   } elsif (    $params->{'magic'}  eq 'suspended'
4366             || $params->{'status'} eq 'suspended'  ) {
4367
4368     push @where, FS::cust_pkg->suspended_sql();
4369
4370   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
4371             || $params->{'status'} =~ /^cancell?ed$/ ) {
4372
4373     push @where, FS::cust_pkg->cancelled_sql();
4374
4375   }
4376
4377   ###
4378   # parse package class
4379   ###
4380
4381   if ( exists($params->{'classnum'}) ) {
4382
4383     my @classnum = ();
4384     if ( ref($params->{'classnum'}) ) {
4385
4386       if ( ref($params->{'classnum'}) eq 'HASH' ) {
4387         @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
4388       } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
4389         @classnum = @{ $params->{'classnum'} };
4390       } else {
4391         die 'unhandled classnum ref '. $params->{'classnum'};
4392       }
4393
4394
4395     } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
4396       @classnum = ( $1 );
4397     }
4398
4399     if ( @classnum ) {
4400
4401       my @c_where = ();
4402       my @nums = grep $_, @classnum;
4403       push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
4404       my $null = scalar( grep { $_ eq '' } @classnum );
4405       push @c_where, 'part_pkg.classnum IS NULL' if $null;
4406
4407       if ( scalar(@c_where) == 1 ) {
4408         push @where, @c_where;
4409       } elsif ( @c_where ) {
4410         push @where, ' ( '. join(' OR ', @c_where). ' ) ';
4411       }
4412
4413     }
4414
4415
4416   }
4417
4418   ###
4419   # parse package report options
4420   ###
4421
4422   my @report_option = ();
4423   if ( exists($params->{'report_option'}) ) {
4424     if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
4425       @report_option = @{ $params->{'report_option'} };
4426     } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
4427       @report_option = split(',', $1);
4428     }
4429
4430   }
4431
4432   if (@report_option) {
4433     # this will result in the empty set for the dangling comma case as it should
4434     push @where,
4435       map{ "0 < ( SELECT count(*) FROM part_pkg_option
4436                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4437                     AND optionname = 'report_option_$_'
4438                     AND optionvalue = '1' )"
4439          } @report_option;
4440   }
4441
4442   foreach my $any ( grep /^report_option_any/, keys %$params ) {
4443
4444     my @report_option_any = ();
4445     if ( ref($params->{$any}) eq 'ARRAY' ) {
4446       @report_option_any = @{ $params->{$any} };
4447     } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
4448       @report_option_any = split(',', $1);
4449     }
4450
4451     if (@report_option_any) {
4452       # this will result in the empty set for the dangling comma case as it should
4453       push @where, ' ( '. join(' OR ',
4454         map{ "0 < ( SELECT count(*) FROM part_pkg_option
4455                       WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4456                       AND optionname = 'report_option_$_'
4457                       AND optionvalue = '1' )"
4458            } @report_option_any
4459       ). ' ) ';
4460     }
4461
4462   }
4463
4464   ###
4465   # parse custom
4466   ###
4467
4468   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
4469
4470   ###
4471   # parse fcc_line
4472   ###
4473
4474   push @where,  "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
4475                                                         if $params->{fcc_line};
4476
4477   ###
4478   # parse censustract
4479   ###
4480
4481   if ( exists($params->{'censustract'}) ) {
4482     $params->{'censustract'} =~ /^([.\d]*)$/;
4483     my $censustract = "cust_location.censustract = '$1'";
4484     $censustract .= ' OR cust_location.censustract is NULL' unless $1;
4485     push @where,  "( $censustract )";
4486   }
4487
4488   ###
4489   # parse censustract2
4490   ###
4491   if ( exists($params->{'censustract2'})
4492        && $params->{'censustract2'} =~ /^(\d*)$/
4493      )
4494   {
4495     if ($1) {
4496       push @where, "cust_location.censustract LIKE '$1%'";
4497     } else {
4498       push @where,
4499         "( cust_location.censustract = '' OR cust_location.censustract IS NULL )";
4500     }
4501   }
4502
4503   ###
4504   # parse country/state
4505   ###
4506   for (qw(state country)) { # parsing rules are the same for these
4507   if ( exists($params->{$_})
4508     && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
4509     {
4510       # XXX post-2.3 only--before that, state/country may be in cust_main
4511       push @where, "cust_location.$_ = '$1'";
4512     }
4513   }
4514
4515   ###
4516   # location_* flags
4517   ###
4518   if ( $params->{location_cust} xor $params->{location_nocust} ) {
4519     my $op = $params->{location_cust} ? '=' : '!=';
4520     push @where, "cust_location.locationnum $op cust_main.ship_locationnum";
4521   }
4522   if ( $params->{location_census} xor $params->{location_nocensus} ) {
4523     my $op = $params->{location_census} ? "IS NOT NULL" : "IS NULL";
4524     push @where, "cust_location.censustract $op";
4525   }
4526   if ( $params->{location_geocode} xor $params->{location_nogeocode} ) {
4527     my $op = $params->{location_geocode} ? "IS NOT NULL" : "IS NULL";
4528     push @where, "cust_location.geocode $op";
4529   }
4530
4531   ###
4532   # parse part_pkg
4533   ###
4534
4535   if ( ref($params->{'pkgpart'}) ) {
4536
4537     my @pkgpart = ();
4538     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
4539       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
4540     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
4541       @pkgpart = @{ $params->{'pkgpart'} };
4542     } else {
4543       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
4544     }
4545
4546     @pkgpart = grep /^(\d+)$/, @pkgpart;
4547
4548     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
4549
4550   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4551     push @where, "pkgpart = $1";
4552   }
4553
4554   ###
4555   # parse dates
4556   ###
4557
4558   my $orderby = '';
4559
4560   #false laziness w/report_cust_pkg.html
4561   my %disable = (
4562     'all'             => {},
4563     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
4564     'active'          => { 'susp'=>1, 'cancel'=>1 },
4565     'suspended'       => { 'cancel' => 1 },
4566     'cancelled'       => {},
4567     ''                => {},
4568   );
4569
4570   if( exists($params->{'active'} ) ) {
4571     # This overrides all the other date-related fields
4572     my($beginning, $ending) = @{$params->{'active'}};
4573     push @where,
4574       "cust_pkg.setup IS NOT NULL",
4575       "cust_pkg.setup <= $ending",
4576       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
4577       "NOT (".FS::cust_pkg->onetime_sql . ")";
4578   }
4579   else {
4580     foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
4581
4582       next unless exists($params->{$field});
4583
4584       my($beginning, $ending) = @{$params->{$field}};
4585
4586       next if $beginning == 0 && $ending == 4294967295;
4587
4588       push @where,
4589         "cust_pkg.$field IS NOT NULL",
4590         "cust_pkg.$field >= $beginning",
4591         "cust_pkg.$field <= $ending";
4592
4593       $orderby ||= "ORDER BY cust_pkg.$field";
4594
4595     }
4596   }
4597
4598   $orderby ||= 'ORDER BY bill';
4599
4600   ###
4601   # parse magic, legacy, etc.
4602   ###
4603
4604   if ( $params->{'magic'} &&
4605        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
4606   ) {
4607
4608     $orderby = 'ORDER BY pkgnum';
4609
4610     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4611       push @where, "pkgpart = $1";
4612     }
4613
4614   } elsif ( $params->{'query'} eq 'pkgnum' ) {
4615
4616     $orderby = 'ORDER BY pkgnum';
4617
4618   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
4619
4620     $orderby = 'ORDER BY pkgnum';
4621
4622     push @where, '0 < (
4623       SELECT count(*) FROM pkg_svc
4624        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
4625          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
4626                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
4627                                      AND cust_svc.svcpart = pkg_svc.svcpart
4628                                 )
4629     )';
4630
4631   }
4632
4633   ##
4634   # setup queries, links, subs, etc. for the search
4635   ##
4636
4637   # here is the agent virtualization
4638   if ($params->{CurrentUser}) {
4639     my $access_user =
4640       qsearchs('access_user', { username => $params->{CurrentUser} });
4641
4642     if ($access_user) {
4643       push @where, $access_user->agentnums_sql('table'=>'cust_main');
4644     } else {
4645       push @where, "1=0";
4646     }
4647   } else {
4648     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
4649   }
4650
4651   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
4652
4653   my $addl_from = 'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
4654                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
4655                   'LEFT JOIN cust_location USING ( locationnum ) '.
4656                   FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg');
4657
4658   my $select;
4659   my $count_query;
4660   if ( $params->{'select_zip5'} ) {
4661     my $zip = 'cust_location.zip';
4662
4663     $select = "DISTINCT substr($zip,1,5) as zip";
4664     $orderby = "ORDER BY substr($zip,1,5)";
4665     $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
4666   } else {
4667     $select = join(', ',
4668                          'cust_pkg.*',
4669                          ( map "part_pkg.$_", qw( pkg freq ) ),
4670                          'pkg_class.classname',
4671                          'cust_main.custnum AS cust_main_custnum',
4672                          FS::UI::Web::cust_sql_fields(
4673                            $params->{'cust_fields'}
4674                          ),
4675                   );
4676     $count_query = 'SELECT COUNT(*)';
4677   }
4678
4679   $count_query .= " FROM cust_pkg $addl_from $extra_sql";
4680
4681   my $sql_query = {
4682     'table'       => 'cust_pkg',
4683     'hashref'     => {},
4684     'select'      => $select,
4685     'extra_sql'   => $extra_sql,
4686     'order_by'    => $orderby,
4687     'addl_from'   => $addl_from,
4688     'count_query' => $count_query,
4689   };
4690
4691 }
4692
4693 =item fcc_477_count
4694
4695 Returns a list of two package counts.  The first is a count of packages
4696 based on the supplied criteria and the second is the count of residential
4697 packages with those same criteria.  Criteria are specified as in the search
4698 method.
4699
4700 =cut
4701
4702 sub fcc_477_count {
4703   my ($class, $params) = @_;
4704
4705   my $sql_query = $class->search( $params );
4706
4707   my $count_sql = delete($sql_query->{'count_query'});
4708   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4709     or die "couldn't parse count_sql";
4710
4711   my $count_sth = dbh->prepare($count_sql)
4712     or die "Error preparing $count_sql: ". dbh->errstr;
4713   $count_sth->execute
4714     or die "Error executing $count_sql: ". $count_sth->errstr;
4715   my $count_arrayref = $count_sth->fetchrow_arrayref;
4716
4717   return ( @$count_arrayref );
4718
4719 }
4720
4721 =item tax_locationnum_sql
4722
4723 Returns an SQL expression for the tax location for a package, based
4724 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4725
4726 =cut
4727
4728 sub tax_locationnum_sql {
4729   my $conf = FS::Conf->new;
4730   if ( $conf->exists('tax-pkg_address') ) {
4731     'cust_pkg.locationnum';
4732   }
4733   elsif ( $conf->exists('tax-ship_address') ) {
4734     'cust_main.ship_locationnum';
4735   }
4736   else {
4737     'cust_main.bill_locationnum';
4738   }
4739 }
4740
4741 =item location_sql
4742
4743 Returns a list: the first item is an SQL fragment identifying matching
4744 packages/customers via location (taking into account shipping and package
4745 address taxation, if enabled), and subsequent items are the parameters to
4746 substitute for the placeholders in that fragment.
4747
4748 =cut
4749
4750 sub location_sql {
4751   my($class, %opt) = @_;
4752   my $ornull = $opt{'ornull'};
4753
4754   my $conf = new FS::Conf;
4755
4756   # '?' placeholders in _location_sql_where
4757   my $x = $ornull ? 3 : 2;
4758   my @bill_param = (
4759     ('district')x3,
4760     ('city')x3,
4761     ('county')x$x,
4762     ('state')x$x,
4763     'country'
4764   );
4765
4766   my $main_where;
4767   my @main_param;
4768   if ( $conf->exists('tax-ship_address') ) {
4769
4770     $main_where = "(
4771          (     ( ship_last IS NULL     OR  ship_last  = '' )
4772            AND ". _location_sql_where('cust_main', '', $ornull ). "
4773          )
4774       OR (       ship_last IS NOT NULL AND ship_last != ''
4775            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4776          )
4777     )";
4778     #    AND payby != 'COMP'
4779
4780     @main_param = ( @bill_param, @bill_param );
4781
4782   } else {
4783
4784     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4785     @main_param = @bill_param;
4786
4787   }
4788
4789   my $where;
4790   my @param;
4791   if ( $conf->exists('tax-pkg_address') ) {
4792
4793     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4794
4795     $where = " (
4796                     ( cust_pkg.locationnum IS     NULL AND $main_where )
4797                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
4798                )
4799              ";
4800     @param = ( @main_param, @bill_param );
4801
4802   } else {
4803
4804     $where = $main_where;
4805     @param = @main_param;
4806
4807   }
4808
4809   ( $where, @param );
4810
4811 }
4812
4813 #subroutine, helper for location_sql
4814 sub _location_sql_where {
4815   my $table  = shift;
4816   my $prefix = @_ ? shift : '';
4817   my $ornull = @_ ? shift : '';
4818
4819 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4820
4821   $ornull = $ornull ? ' OR ? IS NULL ' : '';
4822
4823   my $or_empty_city     = " OR ( ? = '' AND $table.${prefix}city     IS NULL )";
4824   my $or_empty_county   = " OR ( ? = '' AND $table.${prefix}county   IS NULL )";
4825   my $or_empty_state    = " OR ( ? = '' AND $table.${prefix}state    IS NULL )";
4826
4827   my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4828
4829 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
4830   "
4831         ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4832     AND ( $table.${prefix}city     = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4833     AND ( $table.${prefix}county   = ? $or_empty_county $ornull )
4834     AND ( $table.${prefix}state    = ? $or_empty_state  $ornull )
4835     AND   $table.${prefix}country  = ?
4836   ";
4837 }
4838
4839 sub _X_show_zero {
4840   my( $self, $what ) = @_;
4841
4842   my $what_show_zero = $what. '_show_zero';
4843   length($self->$what_show_zero())
4844     ? ($self->$what_show_zero() eq 'Y')
4845     : $self->part_pkg->$what_show_zero();
4846 }
4847
4848 =head1 SUBROUTINES
4849
4850 =over 4
4851
4852 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
4853
4854 CUSTNUM is a customer (see L<FS::cust_main>)
4855
4856 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4857 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
4858 permitted.
4859
4860 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
4861 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
4862 new billing items.  An error is returned if this is not possible (see
4863 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
4864 parameter.
4865
4866 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4867 newly-created cust_pkg objects.
4868
4869 REFNUM, if specified, will specify the FS::pkg_referral record to be created
4870 and inserted.  Multiple FS::pkg_referral records can be created by
4871 setting I<refnum> to an array reference of refnums or a hash reference with
4872 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
4873 record will be created corresponding to cust_main.refnum.
4874
4875 =cut
4876
4877 sub order {
4878   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
4879
4880   my $conf = new FS::Conf;
4881
4882   # Transactionize this whole mess
4883   my $oldAutoCommit = $FS::UID::AutoCommit;
4884   local $FS::UID::AutoCommit = 0;
4885   my $dbh = dbh;
4886
4887   my $error;
4888 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
4889 #  return "Customer not found: $custnum" unless $cust_main;
4890
4891   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
4892     if $DEBUG;
4893
4894   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4895                          @$remove_pkgnum;
4896
4897   my $change = scalar(@old_cust_pkg) != 0;
4898
4899   my %hash = ();
4900   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
4901
4902     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
4903          " to pkgpart ". $pkgparts->[0]. "\n"
4904       if $DEBUG;
4905
4906     my $err_or_cust_pkg =
4907       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
4908                                 'refnum'  => $refnum,
4909                               );
4910
4911     unless (ref($err_or_cust_pkg)) {
4912       $dbh->rollback if $oldAutoCommit;
4913       return $err_or_cust_pkg;
4914     }
4915
4916     push @$return_cust_pkg, $err_or_cust_pkg;
4917     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4918     return '';
4919
4920   }
4921
4922   # Create the new packages.
4923   foreach my $pkgpart (@$pkgparts) {
4924
4925     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
4926
4927     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
4928                                       pkgpart => $pkgpart,
4929                                       refnum  => $refnum,
4930                                       %hash,
4931                                     };
4932     $error = $cust_pkg->insert( 'change' => $change );
4933     push @$return_cust_pkg, $cust_pkg;
4934
4935     foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
4936       my $supp_pkg = FS::cust_pkg->new({
4937           custnum => $custnum,
4938           pkgpart => $link->dst_pkgpart,
4939           refnum  => $refnum,
4940           main_pkgnum => $cust_pkg->pkgnum,
4941           %hash,
4942       });
4943       $error ||= $supp_pkg->insert( 'change' => $change );
4944       push @$return_cust_pkg, $supp_pkg;
4945     }
4946
4947     if ($error) {
4948       $dbh->rollback if $oldAutoCommit;
4949       return $error;
4950     }
4951
4952   }
4953   # $return_cust_pkg now contains refs to all of the newly
4954   # created packages.
4955
4956   # Transfer services and cancel old packages.
4957   foreach my $old_pkg (@old_cust_pkg) {
4958
4959     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
4960       if $DEBUG;
4961
4962     foreach my $new_pkg (@$return_cust_pkg) {
4963       $error = $old_pkg->transfer($new_pkg);
4964       if ($error and $error == 0) {
4965         # $old_pkg->transfer failed.
4966         $dbh->rollback if $oldAutoCommit;
4967         return $error;
4968       }
4969     }
4970
4971     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
4972       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
4973       foreach my $new_pkg (@$return_cust_pkg) {
4974         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
4975         if ($error and $error == 0) {
4976           # $old_pkg->transfer failed.
4977         $dbh->rollback if $oldAutoCommit;
4978         return $error;
4979         }
4980       }
4981     }
4982
4983     if ($error > 0) {
4984       # Transfers were successful, but we went through all of the
4985       # new packages and still had services left on the old package.
4986       # We can't cancel the package under the circumstances, so abort.
4987       $dbh->rollback if $oldAutoCommit;
4988       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
4989     }
4990     $error = $old_pkg->cancel( quiet=>1 );
4991     if ($error) {
4992       $dbh->rollback;
4993       return $error;
4994     }
4995   }
4996   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4997   '';
4998 }
4999
5000 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
5001
5002 A bulk change method to change packages for multiple customers.
5003
5004 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
5005 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
5006 permitted.
5007
5008 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
5009 replace.  The services (see L<FS::cust_svc>) are moved to the
5010 new billing items.  An error is returned if this is not possible (see
5011 L<FS::pkg_svc>).
5012
5013 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
5014 newly-created cust_pkg objects.
5015
5016 =cut
5017
5018 sub bulk_change {
5019   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
5020
5021   # Transactionize this whole mess
5022   my $oldAutoCommit = $FS::UID::AutoCommit;
5023   local $FS::UID::AutoCommit = 0;
5024   my $dbh = dbh;
5025
5026   my @errors;
5027   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
5028                          @$remove_pkgnum;
5029
5030   while(scalar(@old_cust_pkg)) {
5031     my @return = ();
5032     my $custnum = $old_cust_pkg[0]->custnum;
5033     my (@remove) = map { $_->pkgnum }
5034                    grep { $_->custnum == $custnum } @old_cust_pkg;
5035     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
5036
5037     my $error = order $custnum, $pkgparts, \@remove, \@return;
5038
5039     push @errors, $error
5040       if $error;
5041     push @$return_cust_pkg, @return;
5042   }
5043
5044   if (scalar(@errors)) {
5045     $dbh->rollback if $oldAutoCommit;
5046     return join(' / ', @errors);
5047   }
5048
5049   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5050   '';
5051 }
5052
5053 # Used by FS::Upgrade to migrate to a new database.
5054 sub _upgrade_data {  # class method
5055   my ($class, %opts) = @_;
5056   $class->_upgrade_otaker(%opts);
5057   my @statements = (
5058     # RT#10139, bug resulting in contract_end being set when it shouldn't
5059   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
5060     # RT#10830, bad calculation of prorate date near end of year
5061     # the date range for bill is December 2009, and we move it forward
5062     # one year if it's before the previous bill date (which it should
5063     # never be)
5064   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
5065   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
5066   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
5067     # RT6628, add order_date to cust_pkg
5068     'update cust_pkg set order_date = (select history_date from h_cust_pkg
5069         where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
5070         history_action = \'insert\') where order_date is null',
5071   );
5072   foreach my $sql (@statements) {
5073     my $sth = dbh->prepare($sql);
5074     $sth->execute or die $sth->errstr;
5075   }
5076 }
5077
5078 =back
5079
5080 =head1 BUGS
5081
5082 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
5083
5084 In sub order, the @pkgparts array (passed by reference) is clobbered.
5085
5086 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
5087 method to pass dates to the recur_prog expression, it should do so.
5088
5089 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
5090 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
5091 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
5092 configuration values.  Probably need a subroutine which decides what to do
5093 based on whether or not we've fetched the user yet, rather than a hash.  See
5094 FS::UID and the TODO.
5095
5096 Now that things are transactional should the check in the insert method be
5097 moved to check ?
5098
5099 =head1 SEE ALSO
5100
5101 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
5102 L<FS::pkg_svc>, schema.html from the base documentation
5103
5104 =cut
5105
5106 1;
5107