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