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