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 =back
4243
4244 =cut
4245
4246 sub search {
4247   my ($class, $params) = @_;
4248   my @where = ();
4249
4250   ##
4251   # parse agent
4252   ##
4253
4254   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
4255     push @where,
4256       "cust_main.agentnum = $1";
4257   }
4258
4259   ##
4260   # parse cust_status
4261   ##
4262
4263   if ( $params->{'cust_status'} =~ /^([a-z]+)$/ ) {
4264     push @where, FS::cust_main->cust_status_sql . " = '$1' ";
4265   }
4266
4267   ##
4268   # parse customer sales person
4269   ##
4270
4271   if ( $params->{'cust_main_salesnum'} =~ /^(\d+)$/ ) {
4272     push @where, ($1 > 0) ? "cust_main.salesnum = $1"
4273                           : 'cust_main.salesnum IS NULL';
4274   }
4275
4276
4277   ##
4278   # parse sales person
4279   ##
4280
4281   if ( $params->{'salesnum'} =~ /^(\d+)$/ ) {
4282     push @where, ($1 > 0) ? "cust_pkg.salesnum = $1"
4283                           : 'cust_pkg.salesnum IS NULL';
4284   }
4285
4286   ##
4287   # parse custnum
4288   ##
4289
4290   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
4291     push @where,
4292       "cust_pkg.custnum = $1";
4293   }
4294
4295   ##
4296   # custbatch
4297   ##
4298
4299   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
4300     push @where,
4301       "cust_pkg.pkgbatch = '$1'";
4302   }
4303
4304   ##
4305   # parse status
4306   ##
4307
4308   if (    $params->{'magic'}  eq 'active'
4309        || $params->{'status'} eq 'active' ) {
4310
4311     push @where, FS::cust_pkg->active_sql();
4312
4313   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
4314             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
4315
4316     push @where, FS::cust_pkg->not_yet_billed_sql();
4317
4318   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
4319             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
4320
4321     push @where, FS::cust_pkg->inactive_sql();
4322
4323   } elsif (    $params->{'magic'}  eq 'suspended'
4324             || $params->{'status'} eq 'suspended'  ) {
4325
4326     push @where, FS::cust_pkg->suspended_sql();
4327
4328   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
4329             || $params->{'status'} =~ /^cancell?ed$/ ) {
4330
4331     push @where, FS::cust_pkg->cancelled_sql();
4332
4333   }
4334
4335   ###
4336   # parse package class
4337   ###
4338
4339   if ( exists($params->{'classnum'}) ) {
4340
4341     my @classnum = ();
4342     if ( ref($params->{'classnum'}) ) {
4343
4344       if ( ref($params->{'classnum'}) eq 'HASH' ) {
4345         @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
4346       } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
4347         @classnum = @{ $params->{'classnum'} };
4348       } else {
4349         die 'unhandled classnum ref '. $params->{'classnum'};
4350       }
4351
4352
4353     } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
4354       @classnum = ( $1 );
4355     }
4356
4357     if ( @classnum ) {
4358
4359       my @c_where = ();
4360       my @nums = grep $_, @classnum;
4361       push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
4362       my $null = scalar( grep { $_ eq '' } @classnum );
4363       push @c_where, 'part_pkg.classnum IS NULL' if $null;
4364
4365       if ( scalar(@c_where) == 1 ) {
4366         push @where, @c_where;
4367       } elsif ( @c_where ) {
4368         push @where, ' ( '. join(' OR ', @c_where). ' ) ';
4369       }
4370
4371     }
4372
4373
4374   }
4375
4376   ###
4377   # parse package report options
4378   ###
4379
4380   my @report_option = ();
4381   if ( exists($params->{'report_option'}) ) {
4382     if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
4383       @report_option = @{ $params->{'report_option'} };
4384     } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
4385       @report_option = split(',', $1);
4386     }
4387
4388   }
4389
4390   if (@report_option) {
4391     # this will result in the empty set for the dangling comma case as it should
4392     push @where,
4393       map{ "0 < ( SELECT count(*) FROM part_pkg_option
4394                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4395                     AND optionname = 'report_option_$_'
4396                     AND optionvalue = '1' )"
4397          } @report_option;
4398   }
4399
4400   foreach my $any ( grep /^report_option_any/, keys %$params ) {
4401
4402     my @report_option_any = ();
4403     if ( ref($params->{$any}) eq 'ARRAY' ) {
4404       @report_option_any = @{ $params->{$any} };
4405     } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
4406       @report_option_any = split(',', $1);
4407     }
4408
4409     if (@report_option_any) {
4410       # this will result in the empty set for the dangling comma case as it should
4411       push @where, ' ( '. join(' OR ',
4412         map{ "0 < ( SELECT count(*) FROM part_pkg_option
4413                       WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4414                       AND optionname = 'report_option_$_'
4415                       AND optionvalue = '1' )"
4416            } @report_option_any
4417       ). ' ) ';
4418     }
4419
4420   }
4421
4422   ###
4423   # parse custom
4424   ###
4425
4426   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
4427
4428   ###
4429   # parse fcc_line
4430   ###
4431
4432   push @where,  "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
4433                                                         if $params->{fcc_line};
4434
4435   ###
4436   # parse censustract
4437   ###
4438
4439   if ( exists($params->{'censustract'}) ) {
4440     $params->{'censustract'} =~ /^([.\d]*)$/;
4441     my $censustract = "cust_location.censustract = '$1'";
4442     $censustract .= ' OR cust_location.censustract is NULL' unless $1;
4443     push @where,  "( $censustract )";
4444   }
4445
4446   ###
4447   # parse censustract2
4448   ###
4449   if ( exists($params->{'censustract2'})
4450        && $params->{'censustract2'} =~ /^(\d*)$/
4451      )
4452   {
4453     if ($1) {
4454       push @where, "cust_location.censustract LIKE '$1%'";
4455     } else {
4456       push @where,
4457         "( cust_location.censustract = '' OR cust_location.censustract IS NULL )";
4458     }
4459   }
4460
4461   ###
4462   # parse country/state
4463   ###
4464   for (qw(state country)) { # parsing rules are the same for these
4465   if ( exists($params->{$_})
4466     && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
4467     {
4468       # XXX post-2.3 only--before that, state/country may be in cust_main
4469       push @where, "cust_location.$_ = '$1'";
4470     }
4471   }
4472
4473   ###
4474   # parse part_pkg
4475   ###
4476
4477   if ( ref($params->{'pkgpart'}) ) {
4478
4479     my @pkgpart = ();
4480     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
4481       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
4482     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
4483       @pkgpart = @{ $params->{'pkgpart'} };
4484     } else {
4485       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
4486     }
4487
4488     @pkgpart = grep /^(\d+)$/, @pkgpart;
4489
4490     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
4491
4492   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4493     push @where, "pkgpart = $1";
4494   }
4495
4496   ###
4497   # parse dates
4498   ###
4499
4500   my $orderby = '';
4501
4502   #false laziness w/report_cust_pkg.html
4503   my %disable = (
4504     'all'             => {},
4505     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
4506     'active'          => { 'susp'=>1, 'cancel'=>1 },
4507     'suspended'       => { 'cancel' => 1 },
4508     'cancelled'       => {},
4509     ''                => {},
4510   );
4511
4512   if( exists($params->{'active'} ) ) {
4513     # This overrides all the other date-related fields
4514     my($beginning, $ending) = @{$params->{'active'}};
4515     push @where,
4516       "cust_pkg.setup IS NOT NULL",
4517       "cust_pkg.setup <= $ending",
4518       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
4519       "NOT (".FS::cust_pkg->onetime_sql . ")";
4520   }
4521   else {
4522     foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
4523
4524       next unless exists($params->{$field});
4525
4526       my($beginning, $ending) = @{$params->{$field}};
4527
4528       next if $beginning == 0 && $ending == 4294967295;
4529
4530       push @where,
4531         "cust_pkg.$field IS NOT NULL",
4532         "cust_pkg.$field >= $beginning",
4533         "cust_pkg.$field <= $ending";
4534
4535       $orderby ||= "ORDER BY cust_pkg.$field";
4536
4537     }
4538   }
4539
4540   $orderby ||= 'ORDER BY bill';
4541
4542   ###
4543   # parse magic, legacy, etc.
4544   ###
4545
4546   if ( $params->{'magic'} &&
4547        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
4548   ) {
4549
4550     $orderby = 'ORDER BY pkgnum';
4551
4552     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4553       push @where, "pkgpart = $1";
4554     }
4555
4556   } elsif ( $params->{'query'} eq 'pkgnum' ) {
4557
4558     $orderby = 'ORDER BY pkgnum';
4559
4560   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
4561
4562     $orderby = 'ORDER BY pkgnum';
4563
4564     push @where, '0 < (
4565       SELECT count(*) FROM pkg_svc
4566        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
4567          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
4568                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
4569                                      AND cust_svc.svcpart = pkg_svc.svcpart
4570                                 )
4571     )';
4572
4573   }
4574
4575   ##
4576   # setup queries, links, subs, etc. for the search
4577   ##
4578
4579   # here is the agent virtualization
4580   if ($params->{CurrentUser}) {
4581     my $access_user =
4582       qsearchs('access_user', { username => $params->{CurrentUser} });
4583
4584     if ($access_user) {
4585       push @where, $access_user->agentnums_sql('table'=>'cust_main');
4586     } else {
4587       push @where, "1=0";
4588     }
4589   } else {
4590     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
4591   }
4592
4593   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
4594
4595   my $addl_from = 'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
4596                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
4597                   'LEFT JOIN cust_location USING ( locationnum ) '.
4598                   FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg');
4599
4600   my $select;
4601   my $count_query;
4602   if ( $params->{'select_zip5'} ) {
4603     my $zip = 'cust_location.zip';
4604
4605     $select = "DISTINCT substr($zip,1,5) as zip";
4606     $orderby = "ORDER BY substr($zip,1,5)";
4607     $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
4608   } else {
4609     $select = join(', ',
4610                          'cust_pkg.*',
4611                          ( map "part_pkg.$_", qw( pkg freq ) ),
4612                          'pkg_class.classname',
4613                          'cust_main.custnum AS cust_main_custnum',
4614                          FS::UI::Web::cust_sql_fields(
4615                            $params->{'cust_fields'}
4616                          ),
4617                   );
4618     $count_query = 'SELECT COUNT(*)';
4619   }
4620
4621   $count_query .= " FROM cust_pkg $addl_from $extra_sql";
4622
4623   my $sql_query = {
4624     'table'       => 'cust_pkg',
4625     'hashref'     => {},
4626     'select'      => $select,
4627     'extra_sql'   => $extra_sql,
4628     'order_by'    => $orderby,
4629     'addl_from'   => $addl_from,
4630     'count_query' => $count_query,
4631   };
4632
4633 }
4634
4635 =item fcc_477_count
4636
4637 Returns a list of two package counts.  The first is a count of packages
4638 based on the supplied criteria and the second is the count of residential
4639 packages with those same criteria.  Criteria are specified as in the search
4640 method.
4641
4642 =cut
4643
4644 sub fcc_477_count {
4645   my ($class, $params) = @_;
4646
4647   my $sql_query = $class->search( $params );
4648
4649   my $count_sql = delete($sql_query->{'count_query'});
4650   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4651     or die "couldn't parse count_sql";
4652
4653   my $count_sth = dbh->prepare($count_sql)
4654     or die "Error preparing $count_sql: ". dbh->errstr;
4655   $count_sth->execute
4656     or die "Error executing $count_sql: ". $count_sth->errstr;
4657   my $count_arrayref = $count_sth->fetchrow_arrayref;
4658
4659   return ( @$count_arrayref );
4660
4661 }
4662
4663 =item tax_locationnum_sql
4664
4665 Returns an SQL expression for the tax location for a package, based
4666 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4667
4668 =cut
4669
4670 sub tax_locationnum_sql {
4671   my $conf = FS::Conf->new;
4672   if ( $conf->exists('tax-pkg_address') ) {
4673     'cust_pkg.locationnum';
4674   }
4675   elsif ( $conf->exists('tax-ship_address') ) {
4676     'cust_main.ship_locationnum';
4677   }
4678   else {
4679     'cust_main.bill_locationnum';
4680   }
4681 }
4682
4683 =item location_sql
4684
4685 Returns a list: the first item is an SQL fragment identifying matching
4686 packages/customers via location (taking into account shipping and package
4687 address taxation, if enabled), and subsequent items are the parameters to
4688 substitute for the placeholders in that fragment.
4689
4690 =cut
4691
4692 sub location_sql {
4693   my($class, %opt) = @_;
4694   my $ornull = $opt{'ornull'};
4695
4696   my $conf = new FS::Conf;
4697
4698   # '?' placeholders in _location_sql_where
4699   my $x = $ornull ? 3 : 2;
4700   my @bill_param = (
4701     ('district')x3,
4702     ('city')x3,
4703     ('county')x$x,
4704     ('state')x$x,
4705     'country'
4706   );
4707
4708   my $main_where;
4709   my @main_param;
4710   if ( $conf->exists('tax-ship_address') ) {
4711
4712     $main_where = "(
4713          (     ( ship_last IS NULL     OR  ship_last  = '' )
4714            AND ". _location_sql_where('cust_main', '', $ornull ). "
4715          )
4716       OR (       ship_last IS NOT NULL AND ship_last != ''
4717            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4718          )
4719     )";
4720     #    AND payby != 'COMP'
4721
4722     @main_param = ( @bill_param, @bill_param );
4723
4724   } else {
4725
4726     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4727     @main_param = @bill_param;
4728
4729   }
4730
4731   my $where;
4732   my @param;
4733   if ( $conf->exists('tax-pkg_address') ) {
4734
4735     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4736
4737     $where = " (
4738                     ( cust_pkg.locationnum IS     NULL AND $main_where )
4739                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
4740                )
4741              ";
4742     @param = ( @main_param, @bill_param );
4743
4744   } else {
4745
4746     $where = $main_where;
4747     @param = @main_param;
4748
4749   }
4750
4751   ( $where, @param );
4752
4753 }
4754
4755 #subroutine, helper for location_sql
4756 sub _location_sql_where {
4757   my $table  = shift;
4758   my $prefix = @_ ? shift : '';
4759   my $ornull = @_ ? shift : '';
4760
4761 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4762
4763   $ornull = $ornull ? ' OR ? IS NULL ' : '';
4764
4765   my $or_empty_city     = " OR ( ? = '' AND $table.${prefix}city     IS NULL )";
4766   my $or_empty_county   = " OR ( ? = '' AND $table.${prefix}county   IS NULL )";
4767   my $or_empty_state    = " OR ( ? = '' AND $table.${prefix}state    IS NULL )";
4768
4769   my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4770
4771 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
4772   "
4773         ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4774     AND ( $table.${prefix}city     = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4775     AND ( $table.${prefix}county   = ? $or_empty_county $ornull )
4776     AND ( $table.${prefix}state    = ? $or_empty_state  $ornull )
4777     AND   $table.${prefix}country  = ?
4778   ";
4779 }
4780
4781 sub _X_show_zero {
4782   my( $self, $what ) = @_;
4783
4784   my $what_show_zero = $what. '_show_zero';
4785   length($self->$what_show_zero())
4786     ? ($self->$what_show_zero() eq 'Y')
4787     : $self->part_pkg->$what_show_zero();
4788 }
4789
4790 =head1 SUBROUTINES
4791
4792 =over 4
4793
4794 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
4795
4796 CUSTNUM is a customer (see L<FS::cust_main>)
4797
4798 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4799 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
4800 permitted.
4801
4802 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
4803 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
4804 new billing items.  An error is returned if this is not possible (see
4805 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
4806 parameter.
4807
4808 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4809 newly-created cust_pkg objects.
4810
4811 REFNUM, if specified, will specify the FS::pkg_referral record to be created
4812 and inserted.  Multiple FS::pkg_referral records can be created by
4813 setting I<refnum> to an array reference of refnums or a hash reference with
4814 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
4815 record will be created corresponding to cust_main.refnum.
4816
4817 =cut
4818
4819 sub order {
4820   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
4821
4822   my $conf = new FS::Conf;
4823
4824   # Transactionize this whole mess
4825   local $SIG{HUP} = 'IGNORE';
4826   local $SIG{INT} = 'IGNORE';
4827   local $SIG{QUIT} = 'IGNORE';
4828   local $SIG{TERM} = 'IGNORE';
4829   local $SIG{TSTP} = 'IGNORE';
4830   local $SIG{PIPE} = 'IGNORE';
4831
4832   my $oldAutoCommit = $FS::UID::AutoCommit;
4833   local $FS::UID::AutoCommit = 0;
4834   my $dbh = dbh;
4835
4836   my $error;
4837 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
4838 #  return "Customer not found: $custnum" unless $cust_main;
4839
4840   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
4841     if $DEBUG;
4842
4843   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4844                          @$remove_pkgnum;
4845
4846   my $change = scalar(@old_cust_pkg) != 0;
4847
4848   my %hash = ();
4849   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
4850
4851     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
4852          " to pkgpart ". $pkgparts->[0]. "\n"
4853       if $DEBUG;
4854
4855     my $err_or_cust_pkg =
4856       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
4857                                 'refnum'  => $refnum,
4858                               );
4859
4860     unless (ref($err_or_cust_pkg)) {
4861       $dbh->rollback if $oldAutoCommit;
4862       return $err_or_cust_pkg;
4863     }
4864
4865     push @$return_cust_pkg, $err_or_cust_pkg;
4866     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4867     return '';
4868
4869   }
4870
4871   # Create the new packages.
4872   foreach my $pkgpart (@$pkgparts) {
4873
4874     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
4875
4876     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
4877                                       pkgpart => $pkgpart,
4878                                       refnum  => $refnum,
4879                                       %hash,
4880                                     };
4881     $error = $cust_pkg->insert( 'change' => $change );
4882     push @$return_cust_pkg, $cust_pkg;
4883
4884     foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
4885       my $supp_pkg = FS::cust_pkg->new({
4886           custnum => $custnum,
4887           pkgpart => $link->dst_pkgpart,
4888           refnum  => $refnum,
4889           main_pkgnum => $cust_pkg->pkgnum,
4890           %hash,
4891       });
4892       $error ||= $supp_pkg->insert( 'change' => $change );
4893       push @$return_cust_pkg, $supp_pkg;
4894     }
4895
4896     if ($error) {
4897       $dbh->rollback if $oldAutoCommit;
4898       return $error;
4899     }
4900
4901   }
4902   # $return_cust_pkg now contains refs to all of the newly
4903   # created packages.
4904
4905   # Transfer services and cancel old packages.
4906   foreach my $old_pkg (@old_cust_pkg) {
4907
4908     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
4909       if $DEBUG;
4910
4911     foreach my $new_pkg (@$return_cust_pkg) {
4912       $error = $old_pkg->transfer($new_pkg);
4913       if ($error and $error == 0) {
4914         # $old_pkg->transfer failed.
4915         $dbh->rollback if $oldAutoCommit;
4916         return $error;
4917       }
4918     }
4919
4920     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
4921       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
4922       foreach my $new_pkg (@$return_cust_pkg) {
4923         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
4924         if ($error and $error == 0) {
4925           # $old_pkg->transfer failed.
4926         $dbh->rollback if $oldAutoCommit;
4927         return $error;
4928         }
4929       }
4930     }
4931
4932     if ($error > 0) {
4933       # Transfers were successful, but we went through all of the
4934       # new packages and still had services left on the old package.
4935       # We can't cancel the package under the circumstances, so abort.
4936       $dbh->rollback if $oldAutoCommit;
4937       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
4938     }
4939     $error = $old_pkg->cancel( quiet=>1 );
4940     if ($error) {
4941       $dbh->rollback;
4942       return $error;
4943     }
4944   }
4945   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4946   '';
4947 }
4948
4949 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
4950
4951 A bulk change method to change packages for multiple customers.
4952
4953 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4954 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
4955 permitted.
4956
4957 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
4958 replace.  The services (see L<FS::cust_svc>) are moved to the
4959 new billing items.  An error is returned if this is not possible (see
4960 L<FS::pkg_svc>).
4961
4962 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4963 newly-created cust_pkg objects.
4964
4965 =cut
4966
4967 sub bulk_change {
4968   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
4969
4970   # Transactionize this whole mess
4971   local $SIG{HUP} = 'IGNORE';
4972   local $SIG{INT} = 'IGNORE';
4973   local $SIG{QUIT} = 'IGNORE';
4974   local $SIG{TERM} = 'IGNORE';
4975   local $SIG{TSTP} = 'IGNORE';
4976   local $SIG{PIPE} = 'IGNORE';
4977
4978   my $oldAutoCommit = $FS::UID::AutoCommit;
4979   local $FS::UID::AutoCommit = 0;
4980   my $dbh = dbh;
4981
4982   my @errors;
4983   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4984                          @$remove_pkgnum;
4985
4986   while(scalar(@old_cust_pkg)) {
4987     my @return = ();
4988     my $custnum = $old_cust_pkg[0]->custnum;
4989     my (@remove) = map { $_->pkgnum }
4990                    grep { $_->custnum == $custnum } @old_cust_pkg;
4991     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
4992
4993     my $error = order $custnum, $pkgparts, \@remove, \@return;
4994
4995     push @errors, $error
4996       if $error;
4997     push @$return_cust_pkg, @return;
4998   }
4999
5000   if (scalar(@errors)) {
5001     $dbh->rollback if $oldAutoCommit;
5002     return join(' / ', @errors);
5003   }
5004
5005   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5006   '';
5007 }
5008
5009 # Used by FS::Upgrade to migrate to a new database.
5010 sub _upgrade_data {  # class method
5011   my ($class, %opts) = @_;
5012   $class->_upgrade_otaker(%opts);
5013   my @statements = (
5014     # RT#10139, bug resulting in contract_end being set when it shouldn't
5015   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
5016     # RT#10830, bad calculation of prorate date near end of year
5017     # the date range for bill is December 2009, and we move it forward
5018     # one year if it's before the previous bill date (which it should
5019     # never be)
5020   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
5021   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
5022   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
5023     # RT6628, add order_date to cust_pkg
5024     'update cust_pkg set order_date = (select history_date from h_cust_pkg
5025         where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
5026         history_action = \'insert\') where order_date is null',
5027   );
5028   foreach my $sql (@statements) {
5029     my $sth = dbh->prepare($sql);
5030     $sth->execute or die $sth->errstr;
5031   }
5032 }
5033
5034 =back
5035
5036 =head1 BUGS
5037
5038 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
5039
5040 In sub order, the @pkgparts array (passed by reference) is clobbered.
5041
5042 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
5043 method to pass dates to the recur_prog expression, it should do so.
5044
5045 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
5046 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
5047 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
5048 configuration values.  Probably need a subroutine which decides what to do
5049 based on whether or not we've fetched the user yet, rather than a hash.  See
5050 FS::UID and the TODO.
5051
5052 Now that things are transactional should the check in the insert method be
5053 moved to check ?
5054
5055 =head1 SEE ALSO
5056
5057 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
5058 L<FS::pkg_svc>, schema.html from the base documentation
5059
5060 =cut
5061
5062 1;
5063