FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2
   3 use strict;
   4 use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::location_Mixin
   5              FS::m2m_Common FS::option_Common );
   6 use vars qw($disable_agentcheck $DEBUG $me);
   7 use Carp qw(cluck);
   8 use Scalar::Util qw( blessed );
   9 use List::Util qw(max);
  10 use Tie::IxHash;
  11 use Time::Local qw( timelocal timelocal_nocheck );
  12 use MIME::Entity;
  13 use FS::UID qw( getotaker dbh );
  14 use FS::Misc qw( send_email );
  15 use FS::Record qw( qsearch qsearchs );
  16 use FS::CurrentUser;
  17 use FS::cust_svc;
  18 use FS::part_pkg;
  19 use FS::cust_main;
  20 use FS::cust_location;
  21 use FS::pkg_svc;
  22 use FS::cust_bill_pkg;
  23 use FS::cust_pkg_detail;
  24 use FS::cust_event;
  25 use FS::h_cust_svc;
  26 use FS::reg_code;
  27 use FS::part_svc;
  28 use FS::cust_pkg_reason;
  29 use FS::reason;
  30 use FS::cust_pkg_discount;
  31 use FS::discount;
  32 use FS::UI::Web;
  33 use Data::Dumper;
  34
  35 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  36 # setup }
  37 # because they load configuration by setting FS::UID::callback (see TODO)
  38 use FS::svc_acct;
  39 use FS::svc_domain;
  40 use FS::svc_www;
  41 use FS::svc_forward;
  42
  43 # for sending cancel emails in sub cancel
  44 use FS::Conf;
  45
  46 $DEBUG = 0;
  47 $me = '[FS::cust_pkg]';
  48
  49 $disable_agentcheck = 0;
  50
  51 sub _cache {
  52   my $self = shift;
  53   my ( $hashref, $cache ) = @_;
  54   #if ( $hashref->{'pkgpart'} ) {
  55   if ( $hashref->{'pkg'} ) {
  56     # #@{ $self->{'_pkgnum'} } = ();
  57     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  58     # $self->{'_pkgpart'} = $subcache;
  59     # #push @{ $self->{'_pkgnum'} },
  60     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  61     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  62   }
  63   if ( exists $hashref->{'svcnum'} ) {
  64     #@{ $self->{'_pkgnum'} } = ();
  65     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  66     $self->{'_svcnum'} = $subcache;
  67     #push @{ $self->{'_pkgnum'} },
  68     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  69   }
  70 }
  71
  72 =head1 NAME
  73
  74 FS::cust_pkg - Object methods for cust_pkg objects
  75
  76 =head1 SYNOPSIS
  77
  78   use FS::cust_pkg;
  79
  80   $record = new FS::cust_pkg \%hash;
  81   $record = new FS::cust_pkg { 'column' => 'value' };
  82
  83   $error = $record->insert;
  84
  85   $error = $new_record->replace($old_record);
  86
  87   $error = $record->delete;
  88
  89   $error = $record->check;
  90
  91   $error = $record->cancel;
  92
  93   $error = $record->suspend;
  94
  95   $error = $record->unsuspend;
  96
  97   $part_pkg = $record->part_pkg;
  98
  99   @labels = $record->labels;
 100
 101   $seconds = $record->seconds_since($timestamp);
 102
 103   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
 104   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
 105
 106 =head1 DESCRIPTION
 107
 108 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
 109 inherits from FS::Record.  The following fields are currently supported:
 110
 111 =over 4
 112
 113 =item pkgnum
 114
 115 Primary key (assigned automatically for new billing items)
 116
 117 =item custnum
 118
 119 Customer (see L<FS::cust_main>)
 120
 121 =item pkgpart
 122
 123 Billing item definition (see L<FS::part_pkg>)
 124
 125 =item locationnum
 126
 127 Optional link to package location (see L<FS::location>)
 128
 129 =item order_date
 130
 131 date package was ordered (also remains same on changes)
 132
 133 =item start_date
 134
 135 date
 136
 137 =item setup
 138
 139 date
 140
 141 =item bill
 142
 143 date (next bill date)
 144
 145 =item last_bill
 146
 147 last bill date
 148
 149 =item adjourn
 150
 151 date
 152
 153 =item susp
 154
 155 date
 156
 157 =item expire
 158
 159 date
 160
 161 =item contract_end
 162
 163 date
 164
 165 =item cancel
 166
 167 date
 168
 169 =item usernum
 170
 171 order taker (see L<FS::access_user>)
 172
 173 =item manual_flag
 174
 175 If this field is set to 1, disables the automatic
 176 unsuspension of this package when using the B<unsuspendauto> config option.
 177
 178 =item quantity
 179
 180 If not set, defaults to 1
 181
 182 =item change_date
 183
 184 Date of change from previous package
 185
 186 =item change_pkgnum
 187
 188 Previous pkgnum
 189
 190 =item change_pkgpart
 191
 192 Previous pkgpart
 193
 194 =item change_locationnum
 195
 196 Previous locationnum
 197
 198 =item waive_setup
 199
 200 =back
 201
 202 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
 203 are specified as UNIX timestamps; see L<perlfunc/"time">.  Also see
 204 L<Time::Local> and L<Date::Parse> for conversion functions.
 205
 206 =head1 METHODS
 207
 208 =over 4
 209
 210 =item new HASHREF
 211
 212 Create a new billing item.  To add the item to the database, see L<"insert">.
 213
 214 =cut
 215
 216 sub table { 'cust_pkg'; }
 217 sub cust_linked { $_[0]->cust_main_custnum; }
 218 sub cust_unlinked_msg {
 219   my $self = shift;
 220   "WARNING: can't find cust_main.custnum ". $self->custnum.
 221   ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
 222 }
 223
 224 =item insert [ OPTION => VALUE ... ]
 225
 226 Adds this billing item to the database ("Orders" the item).  If there is an
 227 error, returns the error, otherwise returns false.
 228
 229 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
 230 will be used to look up the package definition and agent restrictions will be
 231 ignored.
 232
 233 If the additional field I<refnum> is defined, an FS::pkg_referral record will
 234 be created and inserted.  Multiple FS::pkg_referral records can be created by
 235 setting I<refnum> to an array reference of refnums or a hash reference with
 236 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
 237 record will be created corresponding to cust_main.refnum.
 238
 239 The following options are available:
 240
 241 =over 4
 242
 243 =item change
 244
 245 If set true, supresses any referral credit to a referring customer.
 246
 247 =item options
 248
 249 cust_pkg_option records will be created
 250
 251 =item ticket_subject
 252
 253 a ticket will be added to this customer with this subject
 254
 255 =item ticket_queue
 256
 257 an optional queue name for ticket additions
 258
 259 =back
 260
 261 =cut
 262
 263 sub insert {
 264   my( $self, %options ) = @_;
 265
 266   my $error = $self->check_pkgpart;
 267   return $error if $error;
 268
 269   my $part_pkg = $self->part_pkg;
 270
 271   if ( $part_pkg->option('start_1st', 1) && !$self->start_date ) {
 272     my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
 273     $mon += 1 unless $mday == 1;
 274     until ( $mon < 12 ) { $mon -= 12; $year++; }
 275     $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
 276   }
 277
 278   foreach my $action ( qw(expire adjourn contract_end) ) {
 279     my $months = $part_pkg->option("${action}_months",1);
 280     if($months and !$self->$action) {
 281       my $start = $self->start_date || $self->setup || time;
 282       $self->$action( $part_pkg->add_freq($start, $months) );
 283     }
 284   }
 285
 286   my $free_days = $part_pkg->option('free_days',1);
 287   if ( $free_days && $part_pkg->option('delay_setup',1) ) { #&& !$self->start_date
 288     my ($mday,$mon,$year) = (localtime(time) )[3,4,5];
 289     #my $start_date = ($self->start_date || timelocal(0,0,0,$mday,$mon,$year)) + 86400 * $free_days;
 290     my $start_date = timelocal(0,0,0,$mday,$mon,$year) + 86400 * $free_days;
 291     $self->start_date($start_date);
 292   }
 293
 294   $self->order_date(time);
 295
 296   local $SIG{HUP} = 'IGNORE';
 297   local $SIG{INT} = 'IGNORE';
 298   local $SIG{QUIT} = 'IGNORE';
 299   local $SIG{TERM} = 'IGNORE';
 300   local $SIG{TSTP} = 'IGNORE';
 301   local $SIG{PIPE} = 'IGNORE';
 302
 303   my $oldAutoCommit = $FS::UID::AutoCommit;
 304   local $FS::UID::AutoCommit = 0;
 305   my $dbh = dbh;
 306
 307   $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
 308   if ( $error ) {
 309     $dbh->rollback if $oldAutoCommit;
 310     return $error;
 311   }
 312
 313   $self->refnum($self->cust_main->refnum) unless $self->refnum;
 314   $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
 315   $self->process_m2m( 'link_table'   => 'pkg_referral',
 316                       'target_table' => 'part_referral',
 317                       'params'       => $self->refnum,
 318                     );
 319
 320   if ( $self->discountnum ) {
 321     my $error = $self->insert_discount();
 322     if ( $error ) {
 323       $dbh->rollback if $oldAutoCommit;
 324       return $error;
 325     }
 326   }
 327
 328   #if ( $self->reg_code ) {
 329   #  my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
 330   #  $error = $reg_code->delete;
 331   #  if ( $error ) {
 332   #    $dbh->rollback if $oldAutoCommit;
 333   #    return $error;
 334   #  }
 335   #}
 336
 337   my $conf = new FS::Conf;
 338
 339   if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
 340
 341     #eval '
 342     #  use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
 343     #  use RT;
 344     #';
 345     #die $@ if $@;
 346     #
 347     #RT::LoadConfig();
 348     #RT::Init();
 349     use FS::TicketSystem;
 350     FS::TicketSystem->init();
 351
 352     my $q = new RT::Queue($RT::SystemUser);
 353     $q->Load($options{ticket_queue}) if $options{ticket_queue};
 354     my $t = new RT::Ticket($RT::SystemUser);
 355     my $mime = new MIME::Entity;
 356     $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
 357     $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
 358                 Subject => $options{ticket_subject},
 359                 MIMEObj => $mime,
 360               );
 361     $t->AddLink( Type   => 'MemberOf',
 362                  Target => 'freeside://freeside/cust_main/'. $self->custnum,
 363                );
 364   }
 365
 366   if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
 367     my $queue = new FS::queue {
 368       'job'     => 'FS::cust_main::queueable_print',
 369     };
 370     $error = $queue->insert(
 371       'custnum'  => $self->custnum,
 372       'template' => 'welcome_letter',
 373     );
 374
 375     if ($error) {
 376       warn "can't send welcome letter: $error";
 377     }
 378
 379   }
 380
 381   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 382   '';
 383
 384 }
 385
 386 =item delete
 387
 388 This method now works but you probably shouldn't use it.
 389
 390 You don't want to delete packages, because there would then be no record
 391 the customer ever purchased the package.  Instead, see the cancel method and
 392 hide cancelled packages.
 393
 394 =cut
 395
 396 sub delete {
 397   my $self = shift;
 398
 399   local $SIG{HUP} = 'IGNORE';
 400   local $SIG{INT} = 'IGNORE';
 401   local $SIG{QUIT} = 'IGNORE';
 402   local $SIG{TERM} = 'IGNORE';
 403   local $SIG{TSTP} = 'IGNORE';
 404   local $SIG{PIPE} = 'IGNORE';
 405
 406   my $oldAutoCommit = $FS::UID::AutoCommit;
 407   local $FS::UID::AutoCommit = 0;
 408   my $dbh = dbh;
 409
 410   foreach my $cust_pkg_discount ($self->cust_pkg_discount) {
 411     my $error = $cust_pkg_discount->delete;
 412     if ( $error ) {
 413       $dbh->rollback if $oldAutoCommit;
 414       return $error;
 415     }
 416   }
 417   #cust_bill_pkg_discount?
 418
 419   foreach my $cust_pkg_detail ($self->cust_pkg_detail) {
 420     my $error = $cust_pkg_detail->delete;
 421     if ( $error ) {
 422       $dbh->rollback if $oldAutoCommit;
 423       return $error;
 424     }
 425   }
 426
 427   foreach my $cust_pkg_reason (
 428     qsearchs( {
 429                 'table' => 'cust_pkg_reason',
 430                 'hashref' => { 'pkgnum' => $self->pkgnum },
 431               }
 432             )
 433   ) {
 434     my $error = $cust_pkg_reason->delete;
 435     if ( $error ) {
 436       $dbh->rollback if $oldAutoCommit;
 437       return $error;
 438     }
 439   }
 440
 441   #pkg_referral?
 442
 443   my $error = $self->SUPER::delete(@_);
 444   if ( $error ) {
 445     $dbh->rollback if $oldAutoCommit;
 446     return $error;
 447   }
 448
 449   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 450
 451   '';
 452
 453 }
 454
 455 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
 456
 457 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 458 returns the error, otherwise returns false.
 459
 460 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
 461
 462 Changing pkgpart may have disasterous effects.  See the order subroutine.
 463
 464 setup and bill are normally updated by calling the bill method of a customer
 465 object (see L<FS::cust_main>).
 466
 467 suspend is normally updated by the suspend and unsuspend methods.
 468
 469 cancel is normally updated by the cancel method (and also the order subroutine
 470 in some cases).
 471
 472 Available options are:
 473
 474 =over 4
 475
 476 =item reason
 477
 478 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.
 479
 480 =item reason_otaker
 481
 482 the access_user (see L<FS::access_user>) providing the reason
 483
 484 =item options
 485
 486 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
 487
 488 =back
 489
 490 =cut
 491
 492 sub replace {
 493   my $new = shift;
 494
 495   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 496               ? shift
 497               : $new->replace_old;
 498
 499   my $options =
 500     ( ref($_[0]) eq 'HASH' )
 501       ? shift
 502       : { @_ };
 503
 504   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 505   #return "Can't change otaker!" if $old->otaker ne $new->otaker;
 506
 507   #allow this *sigh*
 508   #return "Can't change setup once it exists!"
 509   #  if $old->getfield('setup') &&
 510   #     $old->getfield('setup') != $new->getfield('setup');
 511
 512   #some logic for bill, susp, cancel?
 513
 514   local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
 515
 516   local $SIG{HUP} = 'IGNORE';
 517   local $SIG{INT} = 'IGNORE';
 518   local $SIG{QUIT} = 'IGNORE';
 519   local $SIG{TERM} = 'IGNORE';
 520   local $SIG{TSTP} = 'IGNORE';
 521   local $SIG{PIPE} = 'IGNORE';
 522
 523   my $oldAutoCommit = $FS::UID::AutoCommit;
 524   local $FS::UID::AutoCommit = 0;
 525   my $dbh = dbh;
 526
 527   foreach my $method ( qw(adjourn expire) ) {  # How many reasons?
 528     if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
 529       my $error = $new->insert_reason(
 530         'reason'        => $options->{'reason'},
 531         'date'          => $new->$method,
 532         'action'        => $method,
 533         'reason_otaker' => $options->{'reason_otaker'},
 534       );
 535       if ( $error ) {
 536         dbh->rollback if $oldAutoCommit;
 537         return "Error inserting cust_pkg_reason: $error";
 538       }
 539     }
 540   }
 541
 542   #save off and freeze RADIUS attributes for any associated svc_acct records
 543   my @svc_acct = ();
 544   if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
 545
 546                 #also check for specific exports?
 547                 # to avoid spurious modify export events
 548     @svc_acct = map  { $_->svc_x }
 549                 grep { $_->part_svc->svcdb eq 'svc_acct' }
 550                      $old->cust_svc;
 551
 552     $_->snapshot foreach @svc_acct;
 553
 554   }
 555
 556   my $error = $new->SUPER::replace($old,
 557                                    $options->{options} ? $options->{options} : ()
 558                                   );
 559   if ( $error ) {
 560     $dbh->rollback if $oldAutoCommit;
 561     return $error;
 562   }
 563
 564   #for prepaid packages,
 565   #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
 566   foreach my $old_svc_acct ( @svc_acct ) {
 567     my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
 568     my $s_error =
 569       $new_svc_acct->replace( $old_svc_acct,
 570                               'depend_jobnum' => $options->{depend_jobnum},
 571                             );
 572     if ( $s_error ) {
 573       $dbh->rollback if $oldAutoCommit;
 574       return $s_error;
 575     }
 576   }
 577
 578   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 579   '';
 580
 581 }
 582
 583 =item check
 584
 585 Checks all fields to make sure this is a valid billing item.  If there is an
 586 error, returns the error, otherwise returns false.  Called by the insert and
 587 replace methods.
 588
 589 =cut
 590
 591 sub check {
 592   my $self = shift;
 593
 594   $self->locationnum('') if !$self->locationnum || $self->locationnum == -1;
 595
 596   my $error =
 597     $self->ut_numbern('pkgnum')
 598     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 599     || $self->ut_numbern('pkgpart')
 600     || $self->check_pkgpart
 601     || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
 602     || $self->ut_numbern('start_date')
 603     || $self->ut_numbern('setup')
 604     || $self->ut_numbern('bill')
 605     || $self->ut_numbern('susp')
 606     || $self->ut_numbern('cancel')
 607     || $self->ut_numbern('adjourn')
 608     || $self->ut_numbern('resume')
 609     || $self->ut_numbern('expire')
 610     || $self->ut_numbern('dundate')
 611     || $self->ut_enum('no_auto', [ '', 'Y' ])
 612     || $self->ut_enum('waive_setup', [ '', 'Y' ])
 613     || $self->ut_numbern('agent_pkgid')
 614     || $self->ut_enum('recur_show_zero', [ '', 'Y', 'N', ])
 615     || $self->ut_enum('setup_show_zero', [ '', 'Y', 'N', ])
 616   ;
 617   return $error if $error;
 618
 619   return "A package with both start date (future start) and setup date (already started) will never bill"
 620     if $self->start_date && $self->setup;
 621
 622   return "A future unsuspend date can only be set for a package with a suspend date"
 623     if $self->resume and !$self->susp and !$self->adjourn;
 624
 625   $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
 626
 627   if ( $self->dbdef_table->column('manual_flag') ) {
 628     $self->manual_flag('') if $self->manual_flag eq ' ';
 629     $self->manual_flag =~ /^([01]?)$/
 630       or return "Illegal manual_flag ". $self->manual_flag;
 631     $self->manual_flag($1);
 632   }
 633
 634   $self->SUPER::check;
 635 }
 636
 637 =item check_pkgpart
 638
 639 =cut
 640
 641 sub check_pkgpart {
 642   my $self = shift;
 643
 644   my $error = $self->ut_numbern('pkgpart');
 645   return $error if $error;
 646
 647   if ( $self->reg_code ) {
 648
 649     unless ( grep { $self->pkgpart == $_->pkgpart }
 650              map  { $_->reg_code_pkg }
 651              qsearchs( 'reg_code', { 'code'     => $self->reg_code,
 652                                      'agentnum' => $self->cust_main->agentnum })
 653            ) {
 654       return "Unknown registration code";
 655     }
 656
 657   } elsif ( $self->promo_code ) {
 658
 659     my $promo_part_pkg =
 660       qsearchs('part_pkg', {
 661         'pkgpart'    => $self->pkgpart,
 662         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 663       } );
 664     return 'Unknown promotional code' unless $promo_part_pkg;
 665
 666   } else {
 667
 668     unless ( $disable_agentcheck ) {
 669       my $agent =
 670         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 671       return "agent ". $agent->agentnum. ':'. $agent->agent.
 672              " can't purchase pkgpart ". $self->pkgpart
 673         unless $agent->pkgpart_hashref->{ $self->pkgpart }
 674             || $agent->agentnum == $self->part_pkg->agentnum;
 675     }
 676
 677     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 678     return $error if $error;
 679
 680   }
 681
 682   '';
 683
 684 }
 685
 686 =item cancel [ OPTION => VALUE ... ]
 687
 688 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 689 in this package, then cancels the package itself (sets the cancel field to
 690 now).
 691
 692 Available options are:
 693
 694 =over 4
 695
 696 =item quiet - can be set true to supress email cancellation notices.
 697
 698 =item time -  can be set to cancel the package based on a specific future or
 699 historical date.  Using time ensures that the remaining amount is calculated
 700 correctly.  Note however that this is an immediate cancel and just changes
 701 the date.  You are PROBABLY looking to expire the account instead of using
 702 this.
 703
 704 =item reason - can be set to a cancellation reason (see L<FS:reason>),
 705 either a reasonnum of an existing reason, or passing a hashref will create
 706 a new reason.  The hashref should have the following keys: typenum - Reason
 707 type (see L<FS::reason_type>, reason - Text of the new reason.
 708
 709 =item date - can be set to a unix style timestamp to specify when to
 710 cancel (expire)
 711
 712 =item nobill - can be set true to skip billing if it might otherwise be done.
 713
 714 =item unused_credit - can be set to 1 to credit the remaining time, or 0 to
 715 not credit it.  This must be set (by change()) when changing the package
 716 to a different pkgpart or location, and probably shouldn't be in any other
 717 case.  If it's not set, the 'unused_credit_cancel' part_pkg option will
 718 be used.
 719
 720 =back
 721
 722 If there is an error, returns the error, otherwise returns false.
 723
 724 =cut
 725
 726 sub cancel {
 727   my( $self, %options ) = @_;
 728   my $error;
 729
 730   my $conf = new FS::Conf;
 731
 732   warn "cust_pkg::cancel called with options".
 733        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 734     if $DEBUG;
 735
 736   local $SIG{HUP} = 'IGNORE';
 737   local $SIG{INT} = 'IGNORE';
 738   local $SIG{QUIT} = 'IGNORE';
 739   local $SIG{TERM} = 'IGNORE';
 740   local $SIG{TSTP} = 'IGNORE';
 741   local $SIG{PIPE} = 'IGNORE';
 742
 743   my $oldAutoCommit = $FS::UID::AutoCommit;
 744   local $FS::UID::AutoCommit = 0;
 745   my $dbh = dbh;
 746
 747   my $old = $self->select_for_update;
 748
 749   if ( $old->get('cancel') || $self->get('cancel') ) {
 750     dbh->rollback if $oldAutoCommit;
 751     return "";  # no error
 752   }
 753
 754   # XXX possibly set cancel_time to the expire date?
 755   my $cancel_time = $options{'time'} || time;
 756   my $date = $options{'date'} if $options{'date'}; # expire/cancel later
 757   $date = '' if ($date && $date <= $cancel_time);      # complain instead?
 758
 759   #race condition: usage could be ongoing until unprovisioned
 760   #resolved by performing a change package instead (which unprovisions) and
 761   #later cancelling
 762   if ( !$options{nobill} && !$date ) {
 763     # && $conf->exists('bill_usage_on_cancel') ) { #calc_cancel checks this
 764       my $copy = $self->new({$self->hash});
 765       my $error =
 766         $copy->cust_main->bill( 'pkg_list' => [ $copy ],
 767                                 'cancel'   => 1,
 768                                 'time'     => $cancel_time );
 769       warn "Error billing during cancel, custnum ".
 770         #$self->cust_main->custnum. ": $error"
 771         ": $error"
 772         if $error;
 773   }
 774
 775   if ( $options{'reason'} ) {
 776     $error = $self->insert_reason( 'reason' => $options{'reason'},
 777                                    'action' => $date ? 'expire' : 'cancel',
 778                                    'date'   => $date ? $date : $cancel_time,
 779                                    'reason_otaker' => $options{'reason_otaker'},
 780                                  );
 781     if ( $error ) {
 782       dbh->rollback if $oldAutoCommit;
 783       return "Error inserting cust_pkg_reason: $error";
 784     }
 785   }
 786
 787   my %svc_cancel_opt = ();
 788   $svc_cancel_opt{'date'} = $date if $date;
 789   foreach my $cust_svc (
 790     #schwartz
 791     map  { $_->[0] }
 792     sort { $a->[1] <=> $b->[1] }
 793     map  { [ $_, $_->svc_x ? $_->svc_x->table_info->{'cancel_weight'} : -1 ]; }
 794     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 795   ) {
 796     my $part_svc = $cust_svc->part_svc;
 797     next if ( defined($part_svc) and $part_svc->preserve );
 798     my $error = $cust_svc->cancel( %svc_cancel_opt );
 799
 800     if ( $error ) {
 801       $dbh->rollback if $oldAutoCommit;
 802       return 'Error '. ($svc_cancel_opt{'date'} ? 'expiring' : 'canceling' ).
 803              " cust_svc: $error";
 804     }
 805   }
 806
 807   unless ($date) {
 808     # credit remaining time if appropriate
 809     my $do_credit;
 810     if ( exists($options{'unused_credit'}) ) {
 811       $do_credit = $options{'unused_credit'};
 812     }
 813     else {
 814       $do_credit = $self->part_pkg->option('unused_credit_cancel', 1);
 815     }
 816     if ( $do_credit ) {
 817       my $error = $self->credit_remaining('cancel', $cancel_time);
 818       if ($error) {
 819         $dbh->rollback if $oldAutoCommit;
 820         return $error;
 821       }
 822     }
 823
 824   } #unless $date
 825
 826   my %hash = $self->hash;
 827   $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
 828   my $new = new FS::cust_pkg ( \%hash );
 829   $error = $new->replace( $self, options => { $self->options } );
 830   if ( $error ) {
 831     $dbh->rollback if $oldAutoCommit;
 832     return $error;
 833   }
 834
 835   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 836   return '' if $date; #no errors
 837
 838   my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
 839   if ( !$options{'quiet'} &&
 840         $conf->exists('emailcancel', $self->cust_main->agentnum) &&
 841         @invoicing_list ) {
 842     my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
 843     my $error = '';
 844     if ( $msgnum ) {
 845       my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
 846       $error = $msg_template->send( 'cust_main' => $self->cust_main,
 847                                     'object'    => $self );
 848     }
 849     else {
 850       $error = send_email(
 851         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 852         'to'      => \@invoicing_list,
 853         'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
 854         'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 855       );
 856     }
 857     #should this do something on errors?
 858   }
 859
 860   ''; #no errors
 861
 862 }
 863
 864 =item cancel_if_expired [ NOW_TIMESTAMP ]
 865
 866 Cancels this package if its expire date has been reached.
 867
 868 =cut
 869
 870 sub cancel_if_expired {
 871   my $self = shift;
 872   my $time = shift || time;
 873   return '' unless $self->expire && $self->expire <= $time;
 874   my $error = $self->cancel;
 875   if ( $error ) {
 876     return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
 877            $self->custnum. ": $error";
 878   }
 879   '';
 880 }
 881
 882 =item unexpire
 883
 884 Cancels any pending expiration (sets the expire field to null).
 885
 886 If there is an error, returns the error, otherwise returns false.
 887
 888 =cut
 889
 890 sub unexpire {
 891   my( $self, %options ) = @_;
 892   my $error;
 893
 894   local $SIG{HUP} = 'IGNORE';
 895   local $SIG{INT} = 'IGNORE';
 896   local $SIG{QUIT} = 'IGNORE';
 897   local $SIG{TERM} = 'IGNORE';
 898   local $SIG{TSTP} = 'IGNORE';
 899   local $SIG{PIPE} = 'IGNORE';
 900
 901   my $oldAutoCommit = $FS::UID::AutoCommit;
 902   local $FS::UID::AutoCommit = 0;
 903   my $dbh = dbh;
 904
 905   my $old = $self->select_for_update;
 906
 907   my $pkgnum = $old->pkgnum;
 908   if ( $old->get('cancel') || $self->get('cancel') ) {
 909     dbh->rollback if $oldAutoCommit;
 910     return "Can't unexpire cancelled package $pkgnum";
 911     # or at least it's pointless
 912   }
 913
 914   unless ( $old->get('expire') && $self->get('expire') ) {
 915     dbh->rollback if $oldAutoCommit;
 916     return "";  # no error
 917   }
 918
 919   my %hash = $self->hash;
 920   $hash{'expire'} = '';
 921   my $new = new FS::cust_pkg ( \%hash );
 922   $error = $new->replace( $self, options => { $self->options } );
 923   if ( $error ) {
 924     $dbh->rollback if $oldAutoCommit;
 925     return $error;
 926   }
 927
 928   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 929
 930   ''; #no errors
 931
 932 }
 933
 934 =item suspend [ OPTION => VALUE ... ]
 935
 936 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 937 package, then suspends the package itself (sets the susp field to now).
 938
 939 Available options are:
 940
 941 =over 4
 942
 943 =item reason - can be set to a cancellation reason (see L<FS:reason>),
 944 either a reasonnum of an existing reason, or passing a hashref will create
 945 a new reason.  The hashref should have the following keys:
 946 - typenum - Reason type (see L<FS::reason_type>
 947 - reason - Text of the new reason.
 948
 949 =item date - can be set to a unix style timestamp to specify when to
 950 suspend (adjourn)
 951
 952 =item time - can be set to override the current time, for calculation
 953 of final invoices or unused-time credits
 954
 955 =item resume_date - can be set to a time when the package should be
 956 unsuspended.  This may be more convenient than calling C<unsuspend()>
 957 separately.
 958
 959 =back
 960
 961 If there is an error, returns the error, otherwise returns false.
 962
 963 =cut
 964
 965 sub suspend {
 966   my( $self, %options ) = @_;
 967   my $error;
 968
 969   local $SIG{HUP} = 'IGNORE';
 970   local $SIG{INT} = 'IGNORE';
 971   local $SIG{QUIT} = 'IGNORE';
 972   local $SIG{TERM} = 'IGNORE';
 973   local $SIG{TSTP} = 'IGNORE';
 974   local $SIG{PIPE} = 'IGNORE';
 975
 976   my $oldAutoCommit = $FS::UID::AutoCommit;
 977   local $FS::UID::AutoCommit = 0;
 978   my $dbh = dbh;
 979
 980   my $old = $self->select_for_update;
 981
 982   my $pkgnum = $old->pkgnum;
 983   if ( $old->get('cancel') || $self->get('cancel') ) {
 984     dbh->rollback if $oldAutoCommit;
 985     return "Can't suspend cancelled package $pkgnum";
 986   }
 987
 988   if ( $old->get('susp') || $self->get('susp') ) {
 989     dbh->rollback if $oldAutoCommit;
 990     return "";  # no error                     # complain on adjourn?
 991   }
 992
 993   my $suspend_time = $options{'time'} || time;
 994   my $date = $options{date} if $options{date}; # adjourn/suspend later
 995   $date = '' if ($date && $date <= $suspend_time); # complain instead?
 996
 997   if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
 998     dbh->rollback if $oldAutoCommit;
 999     return "Package $pkgnum expires before it would be suspended.";
1000   }
1001
1002   # some false laziness with sub cancel
1003   if ( !$options{nobill} && !$date &&
1004        $self->part_pkg->option('bill_suspend_as_cancel',1) ) {
1005     # kind of a kludge--'bill_suspend_as_cancel' to avoid having to
1006     # make the entire cust_main->bill path recognize 'suspend' and
1007     # 'cancel' separately.
1008     warn "Billing $pkgnum on suspension (at $suspend_time)\n" if $DEBUG;
1009     my $copy = $self->new({$self->hash});
1010     my $error =
1011       $copy->cust_main->bill( 'pkg_list' => [ $copy ],
1012                               'cancel'   => 1,
1013                               'time'     => $suspend_time );
1014     warn "Error billing during suspend, custnum ".
1015       #$self->cust_main->custnum. ": $error"
1016       ": $error"
1017       if $error;
1018   }
1019
1020   if ( $options{'reason'} ) {
1021     $error = $self->insert_reason( 'reason' => $options{'reason'},
1022                                    'action' => $date ? 'adjourn' : 'suspend',
1023                                    'date'   => $date ? $date : $suspend_time,
1024                                    'reason_otaker' => $options{'reason_otaker'},
1025                                  );
1026     if ( $error ) {
1027       dbh->rollback if $oldAutoCommit;
1028       return "Error inserting cust_pkg_reason: $error";
1029     }
1030   }
1031
1032   my %hash = $self->hash;
1033   if ( $date ) {
1034     $hash{'adjourn'} = $date;
1035   } else {
1036     $hash{'susp'} = $suspend_time;
1037   }
1038
1039   my $resume_date = $options{'resume_date'} || 0;
1040   if ( $resume_date > ($date || $suspend_time) ) {
1041     $hash{'resume'} = $resume_date;
1042   }
1043
1044   my $new = new FS::cust_pkg ( \%hash );
1045   $error = $new->replace( $self, options => { $self->options } );
1046   if ( $error ) {
1047     $dbh->rollback if $oldAutoCommit;
1048     return $error;
1049   }
1050
1051   unless ( $date ) {
1052     # credit remaining time if appropriate
1053     if ( $self->part_pkg->option('unused_credit_suspend', 1) ) {
1054       my $error = $self->credit_remaining('suspend', $suspend_time);
1055       if ($error) {
1056         $dbh->rollback if $oldAutoCommit;
1057         return $error;
1058       }
1059     }
1060
1061     my @labels = ();
1062
1063     foreach my $cust_svc (
1064       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
1065     ) {
1066       my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1067
1068       $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1069         $dbh->rollback if $oldAutoCommit;
1070         return "Illegal svcdb value in part_svc!";
1071       };
1072       my $svcdb = $1;
1073       require "FS/$svcdb.pm";
1074
1075       my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1076       if ($svc) {
1077         $error = $svc->suspend;
1078         if ( $error ) {
1079           $dbh->rollback if $oldAutoCommit;
1080           return $error;
1081         }
1082         my( $label, $value ) = $cust_svc->label;
1083         push @labels, "$label: $value";
1084       }
1085     }
1086
1087     my $conf = new FS::Conf;
1088     if ( $conf->config('suspend_email_admin') ) {
1089
1090       my $error = send_email(
1091         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
1092                                    #invoice_from ??? well as good as any
1093         'to'      => $conf->config('suspend_email_admin'),
1094         'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
1095         'body'    => [
1096           "This is an automatic message from your Freeside installation\n",
1097           "informing you that the following customer package has been suspended:\n",
1098           "\n",
1099           'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1100           'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1101           ( map { "Service : $_\n" } @labels ),
1102         ],
1103       );
1104
1105       if ( $error ) {
1106         warn "WARNING: can't send suspension admin email (suspending anyway): ".
1107              "$error\n";
1108       }
1109
1110     }
1111
1112   }
1113
1114   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1115
1116   ''; #no errors
1117 }
1118
1119 =item credit_remaining MODE TIME
1120
1121 Generate a credit for this package for the time remaining in the current
1122 billing period.  MODE is either "suspend" or "cancel" (determines the
1123 credit type).  TIME is the time of suspension/cancellation.  Both arguments
1124 are mandatory.
1125
1126 =cut
1127
1128 sub credit_remaining {
1129   # Add a credit for remaining service
1130   my ($self, $mode, $time) = @_;
1131   die 'credit_remaining requires suspend or cancel'
1132     unless $mode eq 'suspend' or $mode eq 'cancel';
1133   die 'no suspend/cancel time' unless $time > 0;
1134
1135   my $conf = FS::Conf->new;
1136   my $reason_type = $conf->config($mode.'_credit_type');
1137
1138   my $last_bill = $self->getfield('last_bill') || 0;
1139   my $next_bill = $self->getfield('bill') || 0;
1140   if ( $last_bill > 0         # the package has been billed
1141       and $next_bill > 0      # the package has a next bill date
1142       and $next_bill >= $time # which is in the future
1143   ) {
1144     my $remaining_value = $self->calc_remain('time' => $time);
1145     if ( $remaining_value > 0 ) {
1146       warn "Crediting for $remaining_value on package ".$self->pkgnum."\n"
1147         if $DEBUG;
1148       my $error = $self->cust_main->credit(
1149         $remaining_value,
1150         'Credit for unused time on '. $self->part_pkg->pkg,
1151         'reason_type' => $reason_type,
1152       );
1153       return "Error crediting customer \$$remaining_value for unused time".
1154         " on ". $self->part_pkg->pkg. ": $error"
1155         if $error;
1156     } #if $remaining_value
1157   } #if $last_bill, etc.
1158   '';
1159 }
1160
1161 =item unsuspend [ OPTION => VALUE ... ]
1162
1163 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1164 package, then unsuspends the package itself (clears the susp field and the
1165 adjourn field if it is in the past).
1166
1167 Available options are:
1168
1169 =over 4
1170
1171 =item date
1172
1173 Can be set to a date to unsuspend the package in the future (the 'resume'
1174 field).
1175
1176 =item adjust_next_bill
1177
1178 Can be set true to adjust the next bill date forward by
1179 the amount of time the account was inactive.  This was set true by default
1180 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
1181 explicitly requested.  Price plans for which this makes sense (anniversary-date
1182 based than prorate or subscription) could have an option to enable this
1183 behaviour?
1184
1185 =back
1186
1187 If there is an error, returns the error, otherwise returns false.
1188
1189 =cut
1190
1191 sub unsuspend {
1192   my( $self, %opt ) = @_;
1193   my $error;
1194
1195   local $SIG{HUP} = 'IGNORE';
1196   local $SIG{INT} = 'IGNORE';
1197   local $SIG{QUIT} = 'IGNORE';
1198   local $SIG{TERM} = 'IGNORE';
1199   local $SIG{TSTP} = 'IGNORE';
1200   local $SIG{PIPE} = 'IGNORE';
1201
1202   my $oldAutoCommit = $FS::UID::AutoCommit;
1203   local $FS::UID::AutoCommit = 0;
1204   my $dbh = dbh;
1205
1206   my $old = $self->select_for_update;
1207
1208   my $pkgnum = $old->pkgnum;
1209   if ( $old->get('cancel') || $self->get('cancel') ) {
1210     $dbh->rollback if $oldAutoCommit;
1211     return "Can't unsuspend cancelled package $pkgnum";
1212   }
1213
1214   unless ( $old->get('susp') && $self->get('susp') ) {
1215     $dbh->rollback if $oldAutoCommit;
1216     return "";  # no error                     # complain instead?
1217   }
1218
1219   my $date = $opt{'date'};
1220   if ( $date and $date > time ) { # return an error if $date <= time?
1221
1222     if ( $old->get('expire') && $old->get('expire') < $date ) {
1223       $dbh->rollback if $oldAutoCommit;
1224       return "Package $pkgnum expires before it would be unsuspended.";
1225     }
1226
1227     my $new = new FS::cust_pkg { $self->hash };
1228     $new->set('resume', $date);
1229     $error = $new->replace($self, options => $self->options);
1230
1231     if ( $error ) {
1232       $dbh->rollback if $oldAutoCommit;
1233       return $error;
1234     }
1235     else {
1236       $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1237       return '';
1238     }
1239
1240   } #if $date
1241
1242   foreach my $cust_svc (
1243     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1244   ) {
1245     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1246
1247     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1248       $dbh->rollback if $oldAutoCommit;
1249       return "Illegal svcdb value in part_svc!";
1250     };
1251     my $svcdb = $1;
1252     require "FS/$svcdb.pm";
1253
1254     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1255     if ($svc) {
1256       $error = $svc->unsuspend;
1257       if ( $error ) {
1258         $dbh->rollback if $oldAutoCommit;
1259         return $error;
1260       }
1261     }
1262
1263   }
1264
1265   my %hash = $self->hash;
1266   my $inactive = time - $hash{'susp'};
1267
1268   my $conf = new FS::Conf;
1269
1270   if ( $inactive > 0 &&
1271        ( $hash{'bill'} || $hash{'setup'} ) &&
1272        ( $opt{'adjust_next_bill'} ||
1273          $conf->exists('unsuspend-always_adjust_next_bill_date') ||
1274          $self->part_pkg->option('unsuspend_adjust_bill', 1) )
1275      ) {
1276
1277     $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
1278
1279   }
1280
1281   $hash{'susp'} = '';
1282   $hash{'adjourn'} = '' if $hash{'adjourn'} and $hash{'adjourn'} < time;
1283   $hash{'resume'} = '' if !$hash{'adjourn'};
1284   my $new = new FS::cust_pkg ( \%hash );
1285   $error = $new->replace( $self, options => { $self->options } );
1286   if ( $error ) {
1287     $dbh->rollback if $oldAutoCommit;
1288     return $error;
1289   }
1290
1291   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1292
1293   ''; #no errors
1294 }
1295
1296 =item unadjourn
1297
1298 Cancels any pending suspension (sets the adjourn field to null).
1299
1300 If there is an error, returns the error, otherwise returns false.
1301
1302 =cut
1303
1304 sub unadjourn {
1305   my( $self, %options ) = @_;
1306   my $error;
1307
1308   local $SIG{HUP} = 'IGNORE';
1309   local $SIG{INT} = 'IGNORE';
1310   local $SIG{QUIT} = 'IGNORE';
1311   local $SIG{TERM} = 'IGNORE';
1312   local $SIG{TSTP} = 'IGNORE';
1313   local $SIG{PIPE} = 'IGNORE';
1314
1315   my $oldAutoCommit = $FS::UID::AutoCommit;
1316   local $FS::UID::AutoCommit = 0;
1317   my $dbh = dbh;
1318
1319   my $old = $self->select_for_update;
1320
1321   my $pkgnum = $old->pkgnum;
1322   if ( $old->get('cancel') || $self->get('cancel') ) {
1323     dbh->rollback if $oldAutoCommit;
1324     return "Can't unadjourn cancelled package $pkgnum";
1325     # or at least it's pointless
1326   }
1327
1328   if ( $old->get('susp') || $self->get('susp') ) {
1329     dbh->rollback if $oldAutoCommit;
1330     return "Can't unadjourn suspended package $pkgnum";
1331     # perhaps this is arbitrary
1332   }
1333
1334   unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1335     dbh->rollback if $oldAutoCommit;
1336     return "";  # no error
1337   }
1338
1339   my %hash = $self->hash;
1340   $hash{'adjourn'} = '';
1341   $hash{'resume'}  = '';
1342   my $new = new FS::cust_pkg ( \%hash );
1343   $error = $new->replace( $self, options => { $self->options } );
1344   if ( $error ) {
1345     $dbh->rollback if $oldAutoCommit;
1346     return $error;
1347   }
1348
1349   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1350
1351   ''; #no errors
1352
1353 }
1354
1355
1356 =item change HASHREF | OPTION => VALUE ...
1357
1358 Changes this package: cancels it and creates a new one, with a different
1359 pkgpart or locationnum or both.  All services are transferred to the new
1360 package (no change will be made if this is not possible).
1361
1362 Options may be passed as a list of key/value pairs or as a hash reference.
1363 Options are:
1364
1365 =over 4
1366
1367 =item locationnum
1368
1369 New locationnum, to change the location for this package.
1370
1371 =item cust_location
1372
1373 New FS::cust_location object, to create a new location and assign it
1374 to this package.
1375
1376 =item pkgpart
1377
1378 New pkgpart (see L<FS::part_pkg>).
1379
1380 =item refnum
1381
1382 New refnum (see L<FS::part_referral>).
1383
1384 =item keep_dates
1385
1386 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
1387 susp, adjourn, cancel, expire, and contract_end) to the new package.
1388
1389 =back
1390
1391 At least one of locationnum, cust_location, pkgpart, refnum must be specified
1392 (otherwise, what's the point?)
1393
1394 Returns either the new FS::cust_pkg object or a scalar error.
1395
1396 For example:
1397
1398   my $err_or_new_cust_pkg = $old_cust_pkg->change
1399
1400 =cut
1401
1402 #some false laziness w/order
1403 sub change {
1404   my $self = shift;
1405   my $opt = ref($_[0]) ? shift : { @_ };
1406
1407 #  my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1408 #
1409
1410   my $conf = new FS::Conf;
1411
1412   # Transactionize this whole mess
1413   local $SIG{HUP} = 'IGNORE';
1414   local $SIG{INT} = 'IGNORE';
1415   local $SIG{QUIT} = 'IGNORE';
1416   local $SIG{TERM} = 'IGNORE';
1417   local $SIG{TSTP} = 'IGNORE';
1418   local $SIG{PIPE} = 'IGNORE';
1419
1420   my $oldAutoCommit = $FS::UID::AutoCommit;
1421   local $FS::UID::AutoCommit = 0;
1422   my $dbh = dbh;
1423
1424   my $error;
1425
1426   my %hash = ();
1427
1428   my $time = time;
1429
1430   #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1431
1432   #$hash{$_} = $self->$_() foreach qw( setup );
1433
1434   $hash{'setup'} = $time if $self->setup;
1435
1436   $hash{'change_date'} = $time;
1437   $hash{"change_$_"}  = $self->$_()
1438     foreach qw( pkgnum pkgpart locationnum );
1439
1440   if ( $opt->{'cust_location'} &&
1441        ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1442     $error = $opt->{'cust_location'}->insert;
1443     if ( $error ) {
1444       $dbh->rollback if $oldAutoCommit;
1445       return "inserting cust_location (transaction rolled back): $error";
1446     }
1447     $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1448   }
1449
1450   my $unused_credit = 0;
1451   my $keep_dates = $opt->{'keep_dates'};
1452   # Special case.  If the pkgpart is changing, and the customer is
1453   # going to be credited for remaining time, don't keep setup, bill,
1454   # or last_bill dates, and DO pass the flag to cancel() to credit
1455   # the customer.
1456   if ( $opt->{'pkgpart'} and $opt->{'pkgpart'} != $self->pkgpart ) {
1457     $keep_dates = 0;
1458     $unused_credit = 1 if $self->part_pkg->option('unused_credit_change', 1);
1459     $hash{$_} = '' foreach qw(setup bill last_bill);
1460   }
1461
1462   if ( $keep_dates ) {
1463     foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1464                           resume start_date contract_end ) ) {
1465       $hash{$date} = $self->getfield($date);
1466     }
1467   }
1468   # allow $opt->{'locationnum'} = '' to specifically set it to null
1469   # (i.e. customer default location)
1470   $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
1471
1472   # Create the new package.
1473   my $cust_pkg = new FS::cust_pkg {
1474     custnum      => $self->custnum,
1475     pkgpart      => ( $opt->{'pkgpart'}     || $self->pkgpart      ),
1476     refnum       => ( $opt->{'refnum'}      || $self->refnum       ),
1477     locationnum  => ( $opt->{'locationnum'}                        ),
1478     %hash,
1479   };
1480
1481   $error = $cust_pkg->insert( 'change' => 1 );
1482   if ($error) {
1483     $dbh->rollback if $oldAutoCommit;
1484     return $error;
1485   }
1486
1487   # Transfer services and cancel old package.
1488
1489   $error = $self->transfer($cust_pkg);
1490   if ($error and $error == 0) {
1491     # $old_pkg->transfer failed.
1492     $dbh->rollback if $oldAutoCommit;
1493     return $error;
1494   }
1495
1496   if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1497     warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1498     $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1499     if ($error and $error == 0) {
1500       # $old_pkg->transfer failed.
1501       $dbh->rollback if $oldAutoCommit;
1502       return $error;
1503     }
1504   }
1505
1506   if ($error > 0) {
1507     # Transfers were successful, but we still had services left on the old
1508     # package.  We can't change the package under this circumstances, so abort.
1509     $dbh->rollback if $oldAutoCommit;
1510     return "Unable to transfer all services from package ". $self->pkgnum;
1511   }
1512
1513   #reset usage if changing pkgpart
1514   # AND usage rollover is off (otherwise adds twice, now and at package bill)
1515   if ($self->pkgpart != $cust_pkg->pkgpart) {
1516     my $part_pkg = $cust_pkg->part_pkg;
1517     $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1518                                                  ? ()
1519                                                  : ( 'null' => 1 )
1520                                    )
1521       if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
1522
1523     if ($error) {
1524       $dbh->rollback if $oldAutoCommit;
1525       return "Error setting usage values: $error";
1526     }
1527   }
1528
1529   #Good to go, cancel old package.  Notify 'cancel' of whether to credit
1530   #remaining time.
1531   #Don't allow billing the package (preceding period packages and/or
1532   #outstanding usage) if we are keeping dates (i.e. location changing),
1533   #because the new package will be billed for the same date range.
1534   $error = $self->cancel(
1535     quiet         => 1,
1536     unused_credit => $unused_credit,
1537     nobill        => $keep_dates
1538   );
1539   if ($error) {
1540     $dbh->rollback if $oldAutoCommit;
1541     return $error;
1542   }
1543
1544   if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1545     #$self->cust_main
1546     my $error = $cust_pkg->cust_main->bill( 'pkg_list' => [ $cust_pkg ] );
1547     if ( $error ) {
1548       $dbh->rollback if $oldAutoCommit;
1549       return $error;
1550     }
1551   }
1552
1553   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1554
1555   $cust_pkg;
1556
1557 }
1558
1559 use Storable 'thaw';
1560 use MIME::Base64;
1561 sub process_bulk_cust_pkg {
1562   my $job = shift;
1563   my $param = thaw(decode_base64(shift));
1564   warn Dumper($param) if $DEBUG;
1565
1566   my $old_part_pkg = qsearchs('part_pkg',
1567                               { pkgpart => $param->{'old_pkgpart'} });
1568   my $new_part_pkg = qsearchs('part_pkg',
1569                               { pkgpart => $param->{'new_pkgpart'} });
1570   die "Must select a new package type\n" unless $new_part_pkg;
1571   #my $keep_dates = $param->{'keep_dates'} || 0;
1572   my $keep_dates = 1; # there is no good reason to turn this off
1573
1574   local $SIG{HUP} = 'IGNORE';
1575   local $SIG{INT} = 'IGNORE';
1576   local $SIG{QUIT} = 'IGNORE';
1577   local $SIG{TERM} = 'IGNORE';
1578   local $SIG{TSTP} = 'IGNORE';
1579   local $SIG{PIPE} = 'IGNORE';
1580
1581   my $oldAutoCommit = $FS::UID::AutoCommit;
1582   local $FS::UID::AutoCommit = 0;
1583   my $dbh = dbh;
1584
1585   my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
1586
1587   my $i = 0;
1588   foreach my $old_cust_pkg ( @cust_pkgs ) {
1589     $i++;
1590     $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
1591     if ( $old_cust_pkg->getfield('cancel') ) {
1592       warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
1593         $old_cust_pkg->pkgnum."\n"
1594         if $DEBUG;
1595       next;
1596     }
1597     warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
1598       if $DEBUG;
1599     my $error = $old_cust_pkg->change(
1600       'pkgpart'     => $param->{'new_pkgpart'},
1601       'keep_dates'  => $keep_dates
1602     );
1603     if ( !ref($error) ) { # change returns the cust_pkg on success
1604       $dbh->rollback;
1605       die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
1606     }
1607   }
1608   $dbh->commit if $oldAutoCommit;
1609   return;
1610 }
1611
1612 =item last_bill
1613
1614 Returns the last bill date, or if there is no last bill date, the setup date.
1615 Useful for billing metered services.
1616
1617 =cut
1618
1619 sub last_bill {
1620   my $self = shift;
1621   return $self->setfield('last_bill', $_[0]) if @_;
1622   return $self->getfield('last_bill') if $self->getfield('last_bill');
1623   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1624                                                   'edate'  => $self->bill,  } );
1625   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1626 }
1627
1628 =item last_cust_pkg_reason ACTION
1629
1630 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1631 Returns false if there is no reason or the package is not currenly ACTION'd
1632 ACTION is one of adjourn, susp, cancel, or expire.
1633
1634 =cut
1635
1636 sub last_cust_pkg_reason {
1637   my ( $self, $action ) = ( shift, shift );
1638   my $date = $self->get($action);
1639   qsearchs( {
1640               'table' => 'cust_pkg_reason',
1641               'hashref' => { 'pkgnum' => $self->pkgnum,
1642                              'action' => substr(uc($action), 0, 1),
1643                              'date'   => $date,
1644                            },
1645               'order_by' => 'ORDER BY num DESC LIMIT 1',
1646            } );
1647 }
1648
1649 =item last_reason ACTION
1650
1651 Returns the most recent ACTION FS::reason associated with the package.
1652 Returns false if there is no reason or the package is not currenly ACTION'd
1653 ACTION is one of adjourn, susp, cancel, or expire.
1654
1655 =cut
1656
1657 sub last_reason {
1658   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1659   $cust_pkg_reason->reason
1660     if $cust_pkg_reason;
1661 }
1662
1663 =item part_pkg
1664
1665 Returns the definition for this billing item, as an FS::part_pkg object (see
1666 L<FS::part_pkg>).
1667
1668 =cut
1669
1670 sub part_pkg {
1671   my $self = shift;
1672   return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1673   cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1674   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1675 }
1676
1677 =item old_cust_pkg
1678
1679 Returns the cancelled package this package was changed from, if any.
1680
1681 =cut
1682
1683 sub old_cust_pkg {
1684   my $self = shift;
1685   return '' unless $self->change_pkgnum;
1686   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1687 }
1688
1689 =item calc_setup
1690
1691 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1692 item.
1693
1694 =cut
1695
1696 sub calc_setup {
1697   my $self = shift;
1698   $self->part_pkg->calc_setup($self, @_);
1699 }
1700
1701 =item calc_recur
1702
1703 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1704 item.
1705
1706 =cut
1707
1708 sub calc_recur {
1709   my $self = shift;
1710   $self->part_pkg->calc_recur($self, @_);
1711 }
1712
1713 =item base_recur
1714
1715 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
1716 item.
1717
1718 =cut
1719
1720 sub base_recur {
1721   my $self = shift;
1722   $self->part_pkg->base_recur($self, @_);
1723 }
1724
1725 =item calc_remain
1726
1727 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1728 billing item.
1729
1730 =cut
1731
1732 sub calc_remain {
1733   my $self = shift;
1734   $self->part_pkg->calc_remain($self, @_);
1735 }
1736
1737 =item calc_cancel
1738
1739 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1740 billing item.
1741
1742 =cut
1743
1744 sub calc_cancel {
1745   my $self = shift;
1746   $self->part_pkg->calc_cancel($self, @_);
1747 }
1748
1749 =item cust_bill_pkg
1750
1751 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1752
1753 =cut
1754
1755 sub cust_bill_pkg {
1756   my $self = shift;
1757   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1758 }
1759
1760 =item cust_pkg_detail [ DETAILTYPE ]
1761
1762 Returns any customer package details for this package (see
1763 L<FS::cust_pkg_detail>).
1764
1765 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1766
1767 =cut
1768
1769 sub cust_pkg_detail {
1770   my $self = shift;
1771   my %hash = ( 'pkgnum' => $self->pkgnum );
1772   $hash{detailtype} = shift if @_;
1773   qsearch({
1774     'table'    => 'cust_pkg_detail',
1775     'hashref'  => \%hash,
1776     'order_by' => 'ORDER BY weight, pkgdetailnum',
1777   });
1778 }
1779
1780 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1781
1782 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1783
1784 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1785
1786 If there is an error, returns the error, otherwise returns false.
1787
1788 =cut
1789
1790 sub set_cust_pkg_detail {
1791   my( $self, $detailtype, @details ) = @_;
1792
1793   local $SIG{HUP} = 'IGNORE';
1794   local $SIG{INT} = 'IGNORE';
1795   local $SIG{QUIT} = 'IGNORE';
1796   local $SIG{TERM} = 'IGNORE';
1797   local $SIG{TSTP} = 'IGNORE';
1798   local $SIG{PIPE} = 'IGNORE';
1799
1800   my $oldAutoCommit = $FS::UID::AutoCommit;
1801   local $FS::UID::AutoCommit = 0;
1802   my $dbh = dbh;
1803
1804   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1805     my $error = $current->delete;
1806     if ( $error ) {
1807       $dbh->rollback if $oldAutoCommit;
1808       return "error removing old detail: $error";
1809     }
1810   }
1811
1812   foreach my $detail ( @details ) {
1813     my $cust_pkg_detail = new FS::cust_pkg_detail {
1814       'pkgnum'     => $self->pkgnum,
1815       'detailtype' => $detailtype,
1816       'detail'     => $detail,
1817     };
1818     my $error = $cust_pkg_detail->insert;
1819     if ( $error ) {
1820       $dbh->rollback if $oldAutoCommit;
1821       return "error adding new detail: $error";
1822     }
1823
1824   }
1825
1826   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1827   '';
1828
1829 }
1830
1831 =item cust_event
1832
1833 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1834
1835 =cut
1836
1837 #false laziness w/cust_bill.pm
1838 sub cust_event {
1839   my $self = shift;
1840   qsearch({
1841     'table'     => 'cust_event',
1842     'addl_from' => 'JOIN part_event USING ( eventpart )',
1843     'hashref'   => { 'tablenum' => $self->pkgnum },
1844     'extra_sql' => " AND eventtable = 'cust_pkg' ",
1845   });
1846 }
1847
1848 =item num_cust_event
1849
1850 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1851
1852 =cut
1853
1854 #false laziness w/cust_bill.pm
1855 sub num_cust_event {
1856   my $self = shift;
1857   my $sql =
1858     "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1859     "  WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1860   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
1861   $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1862   $sth->fetchrow_arrayref->[0];
1863 }
1864
1865 =item cust_svc [ SVCPART ] (old, deprecated usage)
1866
1867 =item cust_svc [ OPTION => VALUE ... ] (current usage)
1868
1869 Returns the services for this package, as FS::cust_svc objects (see
1870 L<FS::cust_svc>).  Available options are svcpart and svcdb.  If either is
1871 spcififed, returns only the matching services.
1872
1873 =cut
1874
1875 sub cust_svc {
1876   my $self = shift;
1877
1878   return () unless $self->num_cust_svc(@_);
1879
1880   my %opt = ();
1881   if ( @_ && $_[0] =~ /^\d+/ ) {
1882     $opt{svcpart} = shift;
1883   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
1884     %opt = %{ $_[0] };
1885   } elsif ( @_ ) {
1886     %opt = @_;
1887   }
1888
1889   my %search = (
1890     'table'   => 'cust_svc',
1891     'hashref' => { 'pkgnum' => $self->pkgnum },
1892   );
1893   if ( $opt{svcpart} ) {
1894     $search{hashref}->{svcpart} = $opt{'svcpart'};
1895   }
1896   if ( $opt{'svcdb'} ) {
1897     $search{addl_from} = ' LEFT JOIN part_svc USING ( svcpart ) ';
1898     $search{hashref}->{svcdb} = $opt{'svcdb'};
1899   }
1900
1901   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1902
1903   #if ( $self->{'_svcnum'} ) {
1904   #  values %{ $self->{'_svcnum'}->cache };
1905   #} else {
1906     $self->_sort_cust_svc( [ qsearch(\%search) ] );
1907   #}
1908
1909 }
1910
1911 =item overlimit [ SVCPART ]
1912
1913 Returns the services for this package which have exceeded their
1914 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
1915 is specified, return only the matching services.
1916
1917 =cut
1918
1919 sub overlimit {
1920   my $self = shift;
1921   return () unless $self->num_cust_svc(@_);
1922   grep { $_->overlimit } $self->cust_svc(@_);
1923 }
1924
1925 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
1926
1927 Returns historical services for this package created before END TIMESTAMP and
1928 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1929 (see L<FS::h_cust_svc>).  If MODE is 'I' (for 'invoice'), services with the
1930 I<pkg_svc.hidden> flag will be omitted.
1931
1932 =cut
1933
1934 sub h_cust_svc {
1935   my $self = shift;
1936   warn "$me _h_cust_svc called on $self\n"
1937     if $DEBUG;
1938
1939   my ($end, $start, $mode) = @_;
1940   my @cust_svc = $self->_sort_cust_svc(
1941     [ qsearch( 'h_cust_svc',
1942       { 'pkgnum' => $self->pkgnum, },
1943       FS::h_cust_svc->sql_h_search(@_),
1944     ) ]
1945   );
1946   if ( defined($mode) && $mode eq 'I' ) {
1947     my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
1948     return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
1949   } else {
1950     return @cust_svc;
1951   }
1952 }
1953
1954 sub _sort_cust_svc {
1955   my( $self, $arrayref ) = @_;
1956
1957   my $sort =
1958     sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] };
1959
1960   map  { $_->[0] }
1961   sort $sort
1962   map {
1963         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1964                                              'svcpart' => $_->svcpart     } );
1965         [ $_,
1966           $pkg_svc ? $pkg_svc->primary_svc : '',
1967           $pkg_svc ? $pkg_svc->quantity : 0,
1968         ];
1969       }
1970   @$arrayref;
1971
1972 }
1973
1974 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
1975
1976 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
1977
1978 Returns the number of services for this package.  Available options are svcpart
1979 and svcdb.  If either is spcififed, returns only the matching services.
1980
1981 =cut
1982
1983 sub num_cust_svc {
1984   my $self = shift;
1985
1986   return $self->{'_num_cust_svc'}
1987     if !scalar(@_)
1988        && exists($self->{'_num_cust_svc'})
1989        && $self->{'_num_cust_svc'} =~ /\d/;
1990
1991   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1992     if $DEBUG > 2;
1993
1994   my %opt = ();
1995   if ( @_ && $_[0] =~ /^\d+/ ) {
1996     $opt{svcpart} = shift;
1997   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
1998     %opt = %{ $_[0] };
1999   } elsif ( @_ ) {
2000     %opt = @_;
2001   }
2002
2003   my $select = 'SELECT COUNT(*) FROM cust_svc ';
2004   my $where = ' WHERE pkgnum = ? ';
2005   my @param = ($self->pkgnum);
2006
2007   if ( $opt{'svcpart'} ) {
2008     $where .= ' AND svcpart = ? ';
2009     push @param, $opt{'svcpart'};
2010   }
2011   if ( $opt{'svcdb'} ) {
2012     $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
2013     $where .= ' AND svcdb = ? ';
2014     push @param, $opt{'svcdb'};
2015   }
2016
2017   my $sth = dbh->prepare("$select $where") or die  dbh->errstr;
2018   $sth->execute(@param) or die $sth->errstr;
2019   $sth->fetchrow_arrayref->[0];
2020 }
2021
2022 =item available_part_svc
2023
2024 Returns a list of FS::part_svc objects representing services included in this
2025 package but not yet provisioned.  Each FS::part_svc object also has an extra
2026 field, I<num_avail>, which specifies the number of available services.
2027
2028 =cut
2029
2030 sub available_part_svc {
2031   my $self = shift;
2032   grep { $_->num_avail > 0 }
2033     map {
2034           my $part_svc = $_->part_svc;
2035           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
2036             $_->quantity - $self->num_cust_svc($_->svcpart);
2037
2038           # more evil encapsulation breakage
2039           if($part_svc->{'Hash'}{'num_avail'} > 0) {
2040             my @exports = $part_svc->part_export_did;
2041             $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
2042           }
2043
2044           $part_svc;
2045         }
2046       $self->part_pkg->pkg_svc;
2047 }
2048
2049 =item part_svc [ OPTION => VALUE ... ]
2050
2051 Returns a list of FS::part_svc objects representing provisioned and available
2052 services included in this package.  Each FS::part_svc object also has the
2053 following extra fields:
2054
2055 =over 4
2056
2057 =item num_cust_svc  (count)
2058
2059 =item num_avail     (quantity - count)
2060
2061 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
2062
2063 =back
2064
2065 Accepts one option: summarize_size.  If specified and non-zero, will omit the
2066 extra cust_pkg_svc option for objects where num_cust_svc is this size or
2067 greater.
2068
2069 =cut
2070
2071 #svcnum
2072 #label -> ($cust_svc->label)[1]
2073
2074 sub part_svc {
2075   my $self = shift;
2076   my %opt = @_;
2077
2078   #XXX some sort of sort order besides numeric by svcpart...
2079   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
2080     my $pkg_svc = $_;
2081     my $part_svc = $pkg_svc->part_svc;
2082     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2083     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
2084     $part_svc->{'Hash'}{'num_avail'}    =
2085       max( 0, $pkg_svc->quantity - $num_cust_svc );
2086     $part_svc->{'Hash'}{'cust_pkg_svc'} =
2087         $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
2088       unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
2089           && $num_cust_svc >= $opt{summarize_size};
2090     $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
2091     $part_svc;
2092   } $self->part_pkg->pkg_svc;
2093
2094   #extras
2095   push @part_svc, map {
2096     my $part_svc = $_;
2097     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2098     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
2099     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
2100     $part_svc->{'Hash'}{'cust_pkg_svc'} =
2101       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
2102     $part_svc;
2103   } $self->extra_part_svc;
2104
2105   @part_svc;
2106
2107 }
2108
2109 =item extra_part_svc
2110
2111 Returns a list of FS::part_svc objects corresponding to services in this
2112 package which are still provisioned but not (any longer) available in the
2113 package definition.
2114
2115 =cut
2116
2117 sub extra_part_svc {
2118   my $self = shift;
2119
2120   my $pkgnum  = $self->pkgnum;
2121   #my $pkgpart = $self->pkgpart;
2122
2123 #  qsearch( {
2124 #    'table'     => 'part_svc',
2125 #    'hashref'   => {},
2126 #    'extra_sql' =>
2127 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
2128 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
2129 #                       AND pkg_svc.pkgpart = ?
2130 #                       AND quantity > 0
2131 #                 )
2132 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
2133 #                       LEFT JOIN cust_pkg USING ( pkgnum )
2134 #                     WHERE cust_svc.svcpart = part_svc.svcpart
2135 #                       AND pkgnum = ?
2136 #                 )",
2137 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
2138 #  } );
2139
2140 #seems to benchmark slightly faster... (or did?)
2141
2142   my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
2143   my $pkgparts = join(',', @pkgparts);
2144
2145   qsearch( {
2146     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
2147     #MySQL doesn't grok DISINCT ON
2148     'select'      => 'DISTINCT part_svc.*',
2149     'table'       => 'part_svc',
2150     'addl_from'   =>
2151       "LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
2152                                AND pkg_svc.pkgpart IN ($pkgparts)
2153                                AND quantity > 0
2154                              )
2155        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
2156        LEFT JOIN cust_pkg USING ( pkgnum )
2157       ",
2158     'hashref'     => {},
2159     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
2160     'extra_param' => [ [$self->pkgnum=>'int'] ],
2161   } );
2162 }
2163
2164 =item status
2165
2166 Returns a short status string for this package, currently:
2167
2168 =over 4
2169
2170 =item not yet billed
2171
2172 =item one-time charge
2173
2174 =item active
2175
2176 =item suspended
2177
2178 =item cancelled
2179
2180 =back
2181
2182 =cut
2183
2184 sub status {
2185   my $self = shift;
2186
2187   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
2188
2189   return 'cancelled' if $self->get('cancel');
2190   return 'suspended' if $self->susp;
2191   return 'not yet billed' unless $self->setup;
2192   return 'one-time charge' if $freq =~ /^(0|$)/;
2193   return 'active';
2194 }
2195
2196 =item ucfirst_status
2197
2198 Returns the status with the first character capitalized.
2199
2200 =cut
2201
2202 sub ucfirst_status {
2203   ucfirst(shift->status);
2204 }
2205
2206 =item statuses
2207
2208 Class method that returns the list of possible status strings for packages
2209 (see L<the status method|/status>).  For example:
2210
2211   @statuses = FS::cust_pkg->statuses();
2212
2213 =cut
2214
2215 tie my %statuscolor, 'Tie::IxHash',
2216   'not yet billed'  => '009999', #teal? cyan?
2217   'one-time charge' => '000000',
2218   'active'          => '00CC00',
2219   'suspended'       => 'FF9900',
2220   'cancelled'       => 'FF0000',
2221 ;
2222
2223 sub statuses {
2224   my $self = shift; #could be class...
2225   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
2226   #                                    # mayble split btw one-time vs. recur
2227     keys %statuscolor;
2228 }
2229
2230 =item statuscolor
2231
2232 Returns a hex triplet color string for this package's status.
2233
2234 =cut
2235
2236 sub statuscolor {
2237   my $self = shift;
2238   $statuscolor{$self->status};
2239 }
2240
2241 =item pkg_label
2242
2243 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
2244 "pkg-comment" depending on user preference).
2245
2246 =cut
2247
2248 sub pkg_label {
2249   my $self = shift;
2250   my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
2251   $label = $self->pkgnum. ": $label"
2252     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
2253   $label;
2254 }
2255
2256 =item pkg_label_long
2257
2258 Returns a long label for this package, adding the primary service's label to
2259 pkg_label.
2260
2261 =cut
2262
2263 sub pkg_label_long {
2264   my $self = shift;
2265   my $label = $self->pkg_label;
2266   my $cust_svc = $self->primary_cust_svc;
2267   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
2268   $label;
2269 }
2270
2271 =item primary_cust_svc
2272
2273 Returns a primary service (as FS::cust_svc object) if one can be identified.
2274
2275 =cut
2276
2277 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
2278
2279 sub primary_cust_svc {
2280   my $self = shift;
2281
2282   my @cust_svc = $self->cust_svc;
2283
2284   return '' unless @cust_svc; #no serivces - irrelevant then
2285
2286   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
2287
2288   # primary service as specified in the package definition
2289   # or exactly one service definition with quantity one
2290   my $svcpart = $self->part_pkg->svcpart;
2291   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
2292   return $cust_svc[0] if scalar(@cust_svc) == 1;
2293
2294   #couldn't identify one thing..
2295   return '';
2296 }
2297
2298 =item labels
2299
2300 Returns a list of lists, calling the label method for all services
2301 (see L<FS::cust_svc>) of this billing item.
2302
2303 =cut
2304
2305 sub labels {
2306   my $self = shift;
2307   map { [ $_->label ] } $self->cust_svc;
2308 }
2309
2310 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2311
2312 Like the labels method, but returns historical information on services that
2313 were active as of END_TIMESTAMP and (optionally) not cancelled before
2314 START_TIMESTAMP.  If MODE is 'I' (for 'invoice'), services with the
2315 I<pkg_svc.hidden> flag will be omitted.
2316
2317 Returns a list of lists, calling the label method for all (historical) services
2318 (see L<FS::h_cust_svc>) of this billing item.
2319
2320 =cut
2321
2322 sub h_labels {
2323   my $self = shift;
2324   warn "$me _h_labels called on $self\n"
2325     if $DEBUG;
2326   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
2327 }
2328
2329 =item labels_short
2330
2331 Like labels, except returns a simple flat list, and shortens long
2332 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2333 identical services to one line that lists the service label and the number of
2334 individual services rather than individual items.
2335
2336 =cut
2337
2338 sub labels_short {
2339   shift->_labels_short( 'labels', @_ );
2340 }
2341
2342 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
2343
2344 Like h_labels, except returns a simple flat list, and shortens long
2345 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2346 identical services to one line that lists the service label and the number of
2347 individual services rather than individual items.
2348
2349 =cut
2350
2351 sub h_labels_short {
2352   shift->_labels_short( 'h_labels', @_ );
2353 }
2354
2355 sub _labels_short {
2356   my( $self, $method ) = ( shift, shift );
2357
2358   warn "$me _labels_short called on $self with $method method\n"
2359     if $DEBUG;
2360
2361   my $conf = new FS::Conf;
2362   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
2363
2364   warn "$me _labels_short populating \%labels\n"
2365     if $DEBUG;
2366
2367   my %labels;
2368   #tie %labels, 'Tie::IxHash';
2369   push @{ $labels{$_->[0]} }, $_->[1]
2370     foreach $self->$method(@_);
2371
2372   warn "$me _labels_short populating \@labels\n"
2373     if $DEBUG;
2374
2375   my @labels;
2376   foreach my $label ( keys %labels ) {
2377     my %seen = ();
2378     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
2379     my $num = scalar(@values);
2380     warn "$me _labels_short $num items for $label\n"
2381       if $DEBUG;
2382
2383     if ( $num > $max_same_services ) {
2384       warn "$me _labels_short   more than $max_same_services, so summarizing\n"
2385         if $DEBUG;
2386       push @labels, "$label ($num)";
2387     } else {
2388       if ( $conf->exists('cust_bill-consolidate_services') ) {
2389         warn "$me _labels_short   consolidating services\n"
2390           if $DEBUG;
2391         # push @labels, "$label: ". join(', ', @values);
2392         while ( @values ) {
2393           my $detail = "$label: ";
2394           $detail .= shift(@values). ', '
2395             while @values
2396                && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
2397           $detail =~ s/, $//;
2398           push @labels, $detail;
2399         }
2400         warn "$me _labels_short   done consolidating services\n"
2401           if $DEBUG;
2402       } else {
2403         warn "$me _labels_short   adding service data\n"
2404           if $DEBUG;
2405         push @labels, map { "$label: $_" } @values;
2406       }
2407     }
2408   }
2409
2410  @labels;
2411
2412 }
2413
2414 =item cust_main
2415
2416 Returns the parent customer object (see L<FS::cust_main>).
2417
2418 =cut
2419
2420 sub cust_main {
2421   my $self = shift;
2422   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
2423 }
2424
2425 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
2426
2427 =item cust_location
2428
2429 Returns the location object, if any (see L<FS::cust_location>).
2430
2431 =item cust_location_or_main
2432
2433 If this package is associated with a location, returns the locaiton (see
2434 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
2435
2436 =item location_label [ OPTION => VALUE ... ]
2437
2438 Returns the label of the location object (see L<FS::cust_location>).
2439
2440 =cut
2441
2442 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2443
2444 =item seconds_since TIMESTAMP
2445
2446 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2447 package have been online since TIMESTAMP, according to the session monitor.
2448
2449 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2450 L<Time::Local> and L<Date::Parse> for conversion functions.
2451
2452 =cut
2453
2454 sub seconds_since {
2455   my($self, $since) = @_;
2456   my $seconds = 0;
2457
2458   foreach my $cust_svc (
2459     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2460   ) {
2461     $seconds += $cust_svc->seconds_since($since);
2462   }
2463
2464   $seconds;
2465
2466 }
2467
2468 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2469
2470 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2471 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2472 (exclusive).
2473
2474 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2475 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2476 functions.
2477
2478
2479 =cut
2480
2481 sub seconds_since_sqlradacct {
2482   my($self, $start, $end) = @_;
2483
2484   my $seconds = 0;
2485
2486   foreach my $cust_svc (
2487     grep {
2488       my $part_svc = $_->part_svc;
2489       $part_svc->svcdb eq 'svc_acct'
2490         && scalar($part_svc->part_export('sqlradius'));
2491     } $self->cust_svc
2492   ) {
2493     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2494   }
2495
2496   $seconds;
2497
2498 }
2499
2500 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2501
2502 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2503 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2504 TIMESTAMP_END
2505 (exclusive).
2506
2507 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2508 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2509 functions.
2510
2511 =cut
2512
2513 sub attribute_since_sqlradacct {
2514   my($self, $start, $end, $attrib) = @_;
2515
2516   my $sum = 0;
2517
2518   foreach my $cust_svc (
2519     grep {
2520       my $part_svc = $_->part_svc;
2521       $part_svc->svcdb eq 'svc_acct'
2522         && scalar($part_svc->part_export('sqlradius'));
2523     } $self->cust_svc
2524   ) {
2525     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2526   }
2527
2528   $sum;
2529
2530 }
2531
2532 =item quantity
2533
2534 =cut
2535
2536 sub quantity {
2537   my( $self, $value ) = @_;
2538   if ( defined($value) ) {
2539     $self->setfield('quantity', $value);
2540   }
2541   $self->getfield('quantity') || 1;
2542 }
2543
2544 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2545
2546 Transfers as many services as possible from this package to another package.
2547
2548 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2549 object.  The destination package must already exist.
2550
2551 Services are moved only if the destination allows services with the correct
2552 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
2553 this option with caution!  No provision is made for export differences
2554 between the old and new service definitions.  Probably only should be used
2555 when your exports for all service definitions of a given svcdb are identical.
2556 (attempt a transfer without it first, to move all possible svcpart-matching
2557 services)
2558
2559 Any services that can't be moved remain in the original package.
2560
2561 Returns an error, if there is one; otherwise, returns the number of services
2562 that couldn't be moved.
2563
2564 =cut
2565
2566 sub transfer {
2567   my ($self, $dest_pkgnum, %opt) = @_;
2568
2569   my $remaining = 0;
2570   my $dest;
2571   my %target;
2572
2573   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2574     $dest = $dest_pkgnum;
2575     $dest_pkgnum = $dest->pkgnum;
2576   } else {
2577     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2578   }
2579
2580   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2581
2582   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2583     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2584   }
2585
2586   foreach my $cust_svc ($dest->cust_svc) {
2587     $target{$cust_svc->svcpart}--;
2588   }
2589
2590   my %svcpart2svcparts = ();
2591   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2592     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2593     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2594       next if exists $svcpart2svcparts{$svcpart};
2595       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2596       $svcpart2svcparts{$svcpart} = [
2597         map  { $_->[0] }
2598         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
2599         map {
2600               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2601                                                    'svcpart' => $_          } );
2602               [ $_,
2603                 $pkg_svc ? $pkg_svc->primary_svc : '',
2604                 $pkg_svc ? $pkg_svc->quantity : 0,
2605               ];
2606             }
2607
2608         grep { $_ != $svcpart }
2609         map  { $_->svcpart }
2610         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2611       ];
2612       warn "alternates for svcpart $svcpart: ".
2613            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2614         if $DEBUG;
2615     }
2616   }
2617
2618   foreach my $cust_svc ($self->cust_svc) {
2619     if($target{$cust_svc->svcpart} > 0) {
2620       $target{$cust_svc->svcpart}--;
2621       my $new = new FS::cust_svc { $cust_svc->hash };
2622       $new->pkgnum($dest_pkgnum);
2623       my $error = $new->replace($cust_svc);
2624       return $error if $error;
2625     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2626       if ( $DEBUG ) {
2627         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2628         warn "alternates to consider: ".
2629              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2630       }
2631       my @alternate = grep {
2632                              warn "considering alternate svcpart $_: ".
2633                                   "$target{$_} available in new package\n"
2634                                if $DEBUG;
2635                              $target{$_} > 0;
2636                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
2637       if ( @alternate ) {
2638         warn "alternate(s) found\n" if $DEBUG;
2639         my $change_svcpart = $alternate[0];
2640         $target{$change_svcpart}--;
2641         my $new = new FS::cust_svc { $cust_svc->hash };
2642         $new->svcpart($change_svcpart);
2643         $new->pkgnum($dest_pkgnum);
2644         my $error = $new->replace($cust_svc);
2645         return $error if $error;
2646       } else {
2647         $remaining++;
2648       }
2649     } else {
2650       $remaining++
2651     }
2652   }
2653   return $remaining;
2654 }
2655
2656 =item reexport
2657
2658 This method is deprecated.  See the I<depend_jobnum> option to the insert and
2659 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2660
2661 =cut
2662
2663 sub reexport {
2664   my $self = shift;
2665
2666   local $SIG{HUP} = 'IGNORE';
2667   local $SIG{INT} = 'IGNORE';
2668   local $SIG{QUIT} = 'IGNORE';
2669   local $SIG{TERM} = 'IGNORE';
2670   local $SIG{TSTP} = 'IGNORE';
2671   local $SIG{PIPE} = 'IGNORE';
2672
2673   my $oldAutoCommit = $FS::UID::AutoCommit;
2674   local $FS::UID::AutoCommit = 0;
2675   my $dbh = dbh;
2676
2677   foreach my $cust_svc ( $self->cust_svc ) {
2678     #false laziness w/svc_Common::insert
2679     my $svc_x = $cust_svc->svc_x;
2680     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2681       my $error = $part_export->export_insert($svc_x);
2682       if ( $error ) {
2683         $dbh->rollback if $oldAutoCommit;
2684         return $error;
2685       }
2686     }
2687   }
2688
2689   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2690   '';
2691
2692 }
2693
2694 =item insert_reason
2695
2696 Associates this package with a (suspension or cancellation) reason (see
2697 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2698 L<FS::reason>).
2699
2700 Available options are:
2701
2702 =over 4
2703
2704 =item reason
2705
2706 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.
2707
2708 =item reason_otaker
2709
2710 the access_user (see L<FS::access_user>) providing the reason
2711
2712 =item date
2713
2714 a unix timestamp
2715
2716 =item action
2717
2718 the action (cancel, susp, adjourn, expire) associated with the reason
2719
2720 =back
2721
2722 If there is an error, returns the error, otherwise returns false.
2723
2724 =cut
2725
2726 sub insert_reason {
2727   my ($self, %options) = @_;
2728
2729   my $otaker = $options{reason_otaker} ||
2730                $FS::CurrentUser::CurrentUser->username;
2731
2732   my $reasonnum;
2733   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2734
2735     $reasonnum = $1;
2736
2737   } elsif ( ref($options{'reason'}) ) {
2738
2739     return 'Enter a new reason (or select an existing one)'
2740       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2741
2742     my $reason = new FS::reason({
2743       'reason_type' => $options{'reason'}->{'typenum'},
2744       'reason'      => $options{'reason'}->{'reason'},
2745     });
2746     my $error = $reason->insert;
2747     return $error if $error;
2748
2749     $reasonnum = $reason->reasonnum;
2750
2751   } else {
2752     return "Unparsable reason: ". $options{'reason'};
2753   }
2754
2755   my $cust_pkg_reason =
2756     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2757                               'reasonnum' => $reasonnum,
2758                               'otaker'    => $otaker,
2759                               'action'    => substr(uc($options{'action'}),0,1),
2760                               'date'      => $options{'date'}
2761                                                ? $options{'date'}
2762                                                : time,
2763                             });
2764
2765   $cust_pkg_reason->insert;
2766 }
2767
2768 =item insert_discount
2769
2770 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
2771 inserting a new discount on the fly (see L<FS::discount>).
2772
2773 Available options are:
2774
2775 =over 4
2776
2777 =item discountnum
2778
2779 =back
2780
2781 If there is an error, returns the error, otherwise returns false.
2782
2783 =cut
2784
2785 sub insert_discount {
2786   #my ($self, %options) = @_;
2787   my $self = shift;
2788
2789   my $cust_pkg_discount = new FS::cust_pkg_discount {
2790     'pkgnum'      => $self->pkgnum,
2791     'discountnum' => $self->discountnum,
2792     'months_used' => 0,
2793     'end_date'    => '', #XXX
2794     #for the create a new discount case
2795     '_type'       => $self->discountnum__type,
2796     'amount'      => $self->discountnum_amount,
2797     'percent'     => $self->discountnum_percent,
2798     'months'      => $self->discountnum_months,
2799     'setup'      => $self->discountnum_setup,
2800     #'disabled'    => $self->discountnum_disabled,
2801   };
2802
2803   $cust_pkg_discount->insert;
2804 }
2805
2806 =item set_usage USAGE_VALUE_HASHREF
2807
2808 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2809 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2810 upbytes, downbytes, and totalbytes are appropriate keys.
2811
2812 All svc_accts which are part of this package have their values reset.
2813
2814 =cut
2815
2816 sub set_usage {
2817   my ($self, $valueref, %opt) = @_;
2818
2819   #only svc_acct can set_usage for now
2820   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
2821     my $svc_x = $cust_svc->svc_x;
2822     $svc_x->set_usage($valueref, %opt)
2823       if $svc_x->can("set_usage");
2824   }
2825 }
2826
2827 =item recharge USAGE_VALUE_HASHREF
2828
2829 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2830 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2831 upbytes, downbytes, and totalbytes are appropriate keys.
2832
2833 All svc_accts which are part of this package have their values incremented.
2834
2835 =cut
2836
2837 sub recharge {
2838   my ($self, $valueref) = @_;
2839
2840   #only svc_acct can set_usage for now
2841   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
2842     my $svc_x = $cust_svc->svc_x;
2843     $svc_x->recharge($valueref)
2844       if $svc_x->can("recharge");
2845   }
2846 }
2847
2848 =item cust_pkg_discount
2849
2850 =cut
2851
2852 sub cust_pkg_discount {
2853   my $self = shift;
2854   qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
2855 }
2856
2857 =item cust_pkg_discount_active
2858
2859 =cut
2860
2861 sub cust_pkg_discount_active {
2862   my $self = shift;
2863   grep { $_->status eq 'active' } $self->cust_pkg_discount;
2864 }
2865
2866 =back
2867
2868 =head1 CLASS METHODS
2869
2870 =over 4
2871
2872 =item recurring_sql
2873
2874 Returns an SQL expression identifying recurring packages.
2875
2876 =cut
2877
2878 sub recurring_sql { "
2879   '0' != ( select freq from part_pkg
2880              where cust_pkg.pkgpart = part_pkg.pkgpart )
2881 "; }
2882
2883 =item onetime_sql
2884
2885 Returns an SQL expression identifying one-time packages.
2886
2887 =cut
2888
2889 sub onetime_sql { "
2890   '0' = ( select freq from part_pkg
2891             where cust_pkg.pkgpart = part_pkg.pkgpart )
2892 "; }
2893
2894 =item ordered_sql
2895
2896 Returns an SQL expression identifying ordered packages (recurring packages not
2897 yet billed).
2898
2899 =cut
2900
2901 sub ordered_sql {
2902    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
2903 }
2904
2905 =item active_sql
2906
2907 Returns an SQL expression identifying active packages.
2908
2909 =cut
2910
2911 sub active_sql {
2912   $_[0]->recurring_sql. "
2913   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2914   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2915   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2916 "; }
2917
2918 =item not_yet_billed_sql
2919
2920 Returns an SQL expression identifying packages which have not yet been billed.
2921
2922 =cut
2923
2924 sub not_yet_billed_sql { "
2925       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
2926   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2927   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2928 "; }
2929
2930 =item inactive_sql
2931
2932 Returns an SQL expression identifying inactive packages (one-time packages
2933 that are otherwise unsuspended/uncancelled).
2934
2935 =cut
2936
2937 sub inactive_sql { "
2938   ". $_[0]->onetime_sql(). "
2939   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2940   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2941   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2942 "; }
2943
2944 =item susp_sql
2945 =item suspended_sql
2946
2947 Returns an SQL expression identifying suspended packages.
2948
2949 =cut
2950
2951 sub suspended_sql { susp_sql(@_); }
2952 sub susp_sql {
2953   #$_[0]->recurring_sql(). ' AND '.
2954   "
2955         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
2956     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
2957   ";
2958 }
2959
2960 =item cancel_sql
2961 =item cancelled_sql
2962
2963 Returns an SQL exprression identifying cancelled packages.
2964
2965 =cut
2966
2967 sub cancelled_sql { cancel_sql(@_); }
2968 sub cancel_sql {
2969   #$_[0]->recurring_sql(). ' AND '.
2970   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2971 }
2972
2973 =item status_sql
2974
2975 Returns an SQL expression to give the package status as a string.
2976
2977 =cut
2978
2979 sub status_sql {
2980 "CASE
2981   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
2982   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
2983   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
2984   WHEN ".onetime_sql()." THEN 'one-time charge'
2985   ELSE 'active'
2986 END"
2987 }
2988
2989 =item search HASHREF
2990
2991 (Class method)
2992
2993 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2994 Valid parameters are
2995
2996 =over 4
2997
2998 =item agentnum
2999
3000 =item magic
3001
3002 active, inactive, suspended, cancel (or cancelled)
3003
3004 =item status
3005
3006 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
3007
3008 =item custom
3009
3010  boolean selects custom packages
3011
3012 =item classnum
3013
3014 =item pkgpart
3015
3016 pkgpart or arrayref or hashref of pkgparts
3017
3018 =item setup
3019
3020 arrayref of beginning and ending epoch date
3021
3022 =item last_bill
3023
3024 arrayref of beginning and ending epoch date
3025
3026 =item bill
3027
3028 arrayref of beginning and ending epoch date
3029
3030 =item adjourn
3031
3032 arrayref of beginning and ending epoch date
3033
3034 =item susp
3035
3036 arrayref of beginning and ending epoch date
3037
3038 =item expire
3039
3040 arrayref of beginning and ending epoch date
3041
3042 =item cancel
3043
3044 arrayref of beginning and ending epoch date
3045
3046 =item query
3047
3048 pkgnum or APKG_pkgnum
3049
3050 =item cust_fields
3051
3052 a value suited to passing to FS::UI::Web::cust_header
3053
3054 =item CurrentUser
3055
3056 specifies the user for agent virtualization
3057
3058 =item fcc_line
3059
3060  boolean selects packages containing fcc form 477 telco lines
3061
3062 =back
3063
3064 =cut
3065
3066 sub search {
3067   my ($class, $params) = @_;
3068   my @where = ();
3069
3070   ##
3071   # parse agent
3072   ##
3073
3074   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
3075     push @where,
3076       "cust_main.agentnum = $1";
3077   }
3078
3079   ##
3080   # parse custnum
3081   ##
3082
3083   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
3084     push @where,
3085       "cust_pkg.custnum = $1";
3086   }
3087
3088   ##
3089   # custbatch
3090   ##
3091
3092   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
3093     push @where,
3094       "cust_pkg.pkgbatch = '$1'";
3095   }
3096
3097   ##
3098   # parse status
3099   ##
3100
3101   if (    $params->{'magic'}  eq 'active'
3102        || $params->{'status'} eq 'active' ) {
3103
3104     push @where, FS::cust_pkg->active_sql();
3105
3106   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
3107             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
3108
3109     push @where, FS::cust_pkg->not_yet_billed_sql();
3110
3111   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
3112             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
3113
3114     push @where, FS::cust_pkg->inactive_sql();
3115
3116   } elsif (    $params->{'magic'}  eq 'suspended'
3117             || $params->{'status'} eq 'suspended'  ) {
3118
3119     push @where, FS::cust_pkg->suspended_sql();
3120
3121   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
3122             || $params->{'status'} =~ /^cancell?ed$/ ) {
3123
3124     push @where, FS::cust_pkg->cancelled_sql();
3125
3126   }
3127
3128   ###
3129   # parse package class
3130   ###
3131
3132   if ( exists($params->{'classnum'}) ) {
3133
3134     my @classnum = ();
3135     if ( ref($params->{'classnum'}) ) {
3136
3137       if ( ref($params->{'classnum'}) eq 'HASH' ) {
3138         @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
3139       } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
3140         @classnum = @{ $params->{'classnum'} };
3141       } else {
3142         die 'unhandled classnum ref '. $params->{'classnum'};
3143       }
3144
3145
3146     } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
3147       @classnum = ( $1 );
3148     }
3149
3150     if ( @classnum ) {
3151
3152       my @c_where = ();
3153       my @nums = grep $_, @classnum;
3154       push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
3155       my $null = scalar( grep { $_ eq '' } @classnum );
3156       push @c_where, 'part_pkg.classnum IS NULL' if $null;
3157
3158       if ( scalar(@c_where) == 1 ) {
3159         push @where, @c_where;
3160       } elsif ( @c_where ) {
3161         push @where, ' ( '. join(' OR ', @c_where). ' ) ';
3162       }
3163
3164     }
3165
3166
3167   }
3168
3169   ###
3170   # parse package report options
3171   ###
3172
3173   my @report_option = ();
3174   if ( exists($params->{'report_option'}) ) {
3175     if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
3176       @report_option = @{ $params->{'report_option'} };
3177     } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
3178       @report_option = split(',', $1);
3179     }
3180
3181   }
3182
3183   if (@report_option) {
3184     # this will result in the empty set for the dangling comma case as it should
3185     push @where,
3186       map{ "0 < ( SELECT count(*) FROM part_pkg_option
3187                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
3188                     AND optionname = 'report_option_$_'
3189                     AND optionvalue = '1' )"
3190          } @report_option;
3191   }
3192
3193   foreach my $any ( grep /^report_option_any/, keys %$params ) {
3194
3195     my @report_option_any = ();
3196     if ( ref($params->{$any}) eq 'ARRAY' ) {
3197       @report_option_any = @{ $params->{$any} };
3198     } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
3199       @report_option_any = split(',', $1);
3200     }
3201
3202     if (@report_option_any) {
3203       # this will result in the empty set for the dangling comma case as it should
3204       push @where, ' ( '. join(' OR ',
3205         map{ "0 < ( SELECT count(*) FROM part_pkg_option
3206                       WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
3207                       AND optionname = 'report_option_$_'
3208                       AND optionvalue = '1' )"
3209            } @report_option_any
3210       ). ' ) ';
3211     }
3212
3213   }
3214
3215   ###
3216   # parse custom
3217   ###
3218
3219   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
3220
3221   ###
3222   # parse fcc_line
3223   ###
3224
3225   push @where,  "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
3226                                                         if $params->{fcc_line};
3227
3228   ###
3229   # parse censustract
3230   ###
3231
3232   if ( exists($params->{'censustract'}) ) {
3233     $params->{'censustract'} =~ /^([.\d]*)$/;
3234     my $censustract = "cust_main.censustract = '$1'";
3235     $censustract .= ' OR cust_main.censustract is NULL' unless $1;
3236     push @where,  "( $censustract )";
3237   }
3238
3239   ###
3240   # parse censustract2
3241   ###
3242   if ( exists($params->{'censustract2'})
3243        && $params->{'censustract2'} =~ /^(\d*)$/
3244      )
3245   {
3246     if ($1) {
3247       push @where, "cust_main.censustract LIKE '$1%'";
3248     } else {
3249       push @where,
3250         "( cust_main.censustract = '' OR cust_main.censustract IS NULL )";
3251     }
3252   }
3253
3254   ###
3255   # parse part_pkg
3256   ###
3257
3258   if ( ref($params->{'pkgpart'}) ) {
3259
3260     my @pkgpart = ();
3261     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
3262       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
3263     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
3264       @pkgpart = @{ $params->{'pkgpart'} };
3265     } else {
3266       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
3267     }
3268
3269     @pkgpart = grep /^(\d+)$/, @pkgpart;
3270
3271     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
3272
3273   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3274     push @where, "pkgpart = $1";
3275   }
3276
3277   ###
3278   # parse dates
3279   ###
3280
3281   my $orderby = '';
3282
3283   #false laziness w/report_cust_pkg.html
3284   my %disable = (
3285     'all'             => {},
3286     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
3287     'active'          => { 'susp'=>1, 'cancel'=>1 },
3288     'suspended'       => { 'cancel' => 1 },
3289     'cancelled'       => {},
3290     ''                => {},
3291   );
3292
3293   if( exists($params->{'active'} ) ) {
3294     # This overrides all the other date-related fields
3295     my($beginning, $ending) = @{$params->{'active'}};
3296     push @where,
3297       "cust_pkg.setup IS NOT NULL",
3298       "cust_pkg.setup <= $ending",
3299       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
3300       "NOT (".FS::cust_pkg->onetime_sql . ")";
3301   }
3302   else {
3303     foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end cancel )) {
3304
3305       next unless exists($params->{$field});
3306
3307       my($beginning, $ending) = @{$params->{$field}};
3308
3309       next if $beginning == 0 && $ending == 4294967295;
3310
3311       push @where,
3312         "cust_pkg.$field IS NOT NULL",
3313         "cust_pkg.$field >= $beginning",
3314         "cust_pkg.$field <= $ending";
3315
3316       $orderby ||= "ORDER BY cust_pkg.$field";
3317
3318     }
3319   }
3320
3321   $orderby ||= 'ORDER BY bill';
3322
3323   ###
3324   # parse magic, legacy, etc.
3325   ###
3326
3327   if ( $params->{'magic'} &&
3328        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
3329   ) {
3330
3331     $orderby = 'ORDER BY pkgnum';
3332
3333     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3334       push @where, "pkgpart = $1";
3335     }
3336
3337   } elsif ( $params->{'query'} eq 'pkgnum' ) {
3338
3339     $orderby = 'ORDER BY pkgnum';
3340
3341   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
3342
3343     $orderby = 'ORDER BY pkgnum';
3344
3345     push @where, '0 < (
3346       SELECT count(*) FROM pkg_svc
3347        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
3348          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
3349                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
3350                                      AND cust_svc.svcpart = pkg_svc.svcpart
3351                                 )
3352     )';
3353
3354   }
3355
3356   ##
3357   # setup queries, links, subs, etc. for the search
3358   ##
3359
3360   # here is the agent virtualization
3361   if ($params->{CurrentUser}) {
3362     my $access_user =
3363       qsearchs('access_user', { username => $params->{CurrentUser} });
3364
3365     if ($access_user) {
3366       push @where, $access_user->agentnums_sql('table'=>'cust_main');
3367     } else {
3368       push @where, "1=0";
3369     }
3370   } else {
3371     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
3372   }
3373
3374   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
3375
3376   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
3377                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
3378                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) ';
3379
3380   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
3381
3382   my $sql_query = {
3383     'table'       => 'cust_pkg',
3384     'hashref'     => {},
3385     'select'      => join(', ',
3386                                 'cust_pkg.*',
3387                                 ( map "part_pkg.$_", qw( pkg freq ) ),
3388                                 'pkg_class.classname',
3389                                 'cust_main.custnum AS cust_main_custnum',
3390                                 FS::UI::Web::cust_sql_fields(
3391                                   $params->{'cust_fields'}
3392                                 ),
3393                      ),
3394     'extra_sql'   => $extra_sql,
3395     'order_by'    => $orderby,
3396     'addl_from'   => $addl_from,
3397     'count_query' => $count_query,
3398   };
3399
3400 }
3401
3402 =item fcc_477_count
3403
3404 Returns a list of two package counts.  The first is a count of packages
3405 based on the supplied criteria and the second is the count of residential
3406 packages with those same criteria.  Criteria are specified as in the search
3407 method.
3408
3409 =cut
3410
3411 sub fcc_477_count {
3412   my ($class, $params) = @_;
3413
3414   my $sql_query = $class->search( $params );
3415
3416   my $count_sql = delete($sql_query->{'count_query'});
3417   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
3418     or die "couldn't parse count_sql";
3419
3420   my $count_sth = dbh->prepare($count_sql)
3421     or die "Error preparing $count_sql: ". dbh->errstr;
3422   $count_sth->execute
3423     or die "Error executing $count_sql: ". $count_sth->errstr;
3424   my $count_arrayref = $count_sth->fetchrow_arrayref;
3425
3426   return ( @$count_arrayref );
3427
3428 }
3429
3430
3431 =item location_sql
3432
3433 Returns a list: the first item is an SQL fragment identifying matching
3434 packages/customers via location (taking into account shipping and package
3435 address taxation, if enabled), and subsequent items are the parameters to
3436 substitute for the placeholders in that fragment.
3437
3438 =cut
3439
3440 sub location_sql {
3441   my($class, %opt) = @_;
3442   my $ornull = $opt{'ornull'};
3443
3444   my $conf = new FS::Conf;
3445
3446   # '?' placeholders in _location_sql_where
3447   my $x = $ornull ? 3 : 2;
3448   my @bill_param = ( ('city')x3, ('county')x$x, ('state')x$x, 'country' );
3449
3450   my $main_where;
3451   my @main_param;
3452   if ( $conf->exists('tax-ship_address') ) {
3453
3454     $main_where = "(
3455          (     ( ship_last IS NULL     OR  ship_last  = '' )
3456            AND ". _location_sql_where('cust_main', '', $ornull ). "
3457          )
3458       OR (       ship_last IS NOT NULL AND ship_last != ''
3459            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
3460          )
3461     )";
3462     #    AND payby != 'COMP'
3463
3464     @main_param = ( @bill_param, @bill_param );
3465
3466   } else {
3467
3468     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
3469     @main_param = @bill_param;
3470
3471   }
3472
3473   my $where;
3474   my @param;
3475   if ( $conf->exists('tax-pkg_address') ) {
3476
3477     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
3478
3479     $where = " (
3480                     ( cust_pkg.locationnum IS     NULL AND $main_where )
3481                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
3482                )
3483              ";
3484     @param = ( @main_param, @bill_param );
3485
3486   } else {
3487
3488     $where = $main_where;
3489     @param = @main_param;
3490
3491   }
3492
3493   ( $where, @param );
3494
3495 }
3496
3497 #subroutine, helper for location_sql
3498 sub _location_sql_where {
3499   my $table  = shift;
3500   my $prefix = @_ ? shift : '';
3501   my $ornull = @_ ? shift : '';
3502
3503 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
3504
3505   $ornull = $ornull ? ' OR ? IS NULL ' : '';
3506
3507   my $or_empty_city   = " OR ( ? = '' AND $table.${prefix}city   IS NULL ) ";
3508   my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
3509   my $or_empty_state =  " OR ( ? = '' AND $table.${prefix}state  IS NULL ) ";
3510
3511 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
3512   "
3513         ( $table.${prefix}city    = ? OR ? = '' OR CAST(? AS text) IS NULL )
3514     AND ( $table.${prefix}county  = ? $or_empty_county $ornull )
3515     AND ( $table.${prefix}state   = ? $or_empty_state  $ornull )
3516     AND   $table.${prefix}country = ?
3517   ";
3518 }
3519
3520 sub _X_show_zero {
3521   my( $self, $what ) = @_;
3522
3523   my $what_show_zero = $what. '_show_zero';
3524   length($self->$what_show_zero())
3525     ? ($self->$what_show_zero() eq 'Y')
3526     : $self->part_pkg->$what_show_zero();
3527 }
3528
3529 =head1 SUBROUTINES
3530
3531 =over 4
3532
3533 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
3534
3535 CUSTNUM is a customer (see L<FS::cust_main>)
3536
3537 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3538 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
3539 permitted.
3540
3541 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
3542 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
3543 new billing items.  An error is returned if this is not possible (see
3544 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
3545 parameter.
3546
3547 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3548 newly-created cust_pkg objects.
3549
3550 REFNUM, if specified, will specify the FS::pkg_referral record to be created
3551 and inserted.  Multiple FS::pkg_referral records can be created by
3552 setting I<refnum> to an array reference of refnums or a hash reference with
3553 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
3554 record will be created corresponding to cust_main.refnum.
3555
3556 =cut
3557
3558 sub order {
3559   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
3560
3561   my $conf = new FS::Conf;
3562
3563   # Transactionize this whole mess
3564   local $SIG{HUP} = 'IGNORE';
3565   local $SIG{INT} = 'IGNORE';
3566   local $SIG{QUIT} = 'IGNORE';
3567   local $SIG{TERM} = 'IGNORE';
3568   local $SIG{TSTP} = 'IGNORE';
3569   local $SIG{PIPE} = 'IGNORE';
3570
3571   my $oldAutoCommit = $FS::UID::AutoCommit;
3572   local $FS::UID::AutoCommit = 0;
3573   my $dbh = dbh;
3574
3575   my $error;
3576 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
3577 #  return "Customer not found: $custnum" unless $cust_main;
3578
3579   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
3580     if $DEBUG;
3581
3582   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3583                          @$remove_pkgnum;
3584
3585   my $change = scalar(@old_cust_pkg) != 0;
3586
3587   my %hash = ();
3588   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
3589
3590     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
3591          " to pkgpart ". $pkgparts->[0]. "\n"
3592       if $DEBUG;
3593
3594     my $err_or_cust_pkg =
3595       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3596                                 'refnum'  => $refnum,
3597                               );
3598
3599     unless (ref($err_or_cust_pkg)) {
3600       $dbh->rollback if $oldAutoCommit;
3601       return $err_or_cust_pkg;
3602     }
3603
3604     push @$return_cust_pkg, $err_or_cust_pkg;
3605     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3606     return '';
3607
3608   }
3609
3610   # Create the new packages.
3611   foreach my $pkgpart (@$pkgparts) {
3612
3613     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3614
3615     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3616                                       pkgpart => $pkgpart,
3617                                       refnum  => $refnum,
3618                                       %hash,
3619                                     };
3620     $error = $cust_pkg->insert( 'change' => $change );
3621     if ($error) {
3622       $dbh->rollback if $oldAutoCommit;
3623       return $error;
3624     }
3625     push @$return_cust_pkg, $cust_pkg;
3626   }
3627   # $return_cust_pkg now contains refs to all of the newly
3628   # created packages.
3629
3630   # Transfer services and cancel old packages.
3631   foreach my $old_pkg (@old_cust_pkg) {
3632
3633     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3634       if $DEBUG;
3635
3636     foreach my $new_pkg (@$return_cust_pkg) {
3637       $error = $old_pkg->transfer($new_pkg);
3638       if ($error and $error == 0) {
3639         # $old_pkg->transfer failed.
3640         $dbh->rollback if $oldAutoCommit;
3641         return $error;
3642       }
3643     }
3644
3645     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3646       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3647       foreach my $new_pkg (@$return_cust_pkg) {
3648         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3649         if ($error and $error == 0) {
3650           # $old_pkg->transfer failed.
3651         $dbh->rollback if $oldAutoCommit;
3652         return $error;
3653         }
3654       }
3655     }
3656
3657     if ($error > 0) {
3658       # Transfers were successful, but we went through all of the
3659       # new packages and still had services left on the old package.
3660       # We can't cancel the package under the circumstances, so abort.
3661       $dbh->rollback if $oldAutoCommit;
3662       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3663     }
3664     $error = $old_pkg->cancel( quiet=>1 );
3665     if ($error) {
3666       $dbh->rollback;
3667       return $error;
3668     }
3669   }
3670   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3671   '';
3672 }
3673
3674 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3675
3676 A bulk change method to change packages for multiple customers.
3677
3678 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3679 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
3680 permitted.
3681
3682 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3683 replace.  The services (see L<FS::cust_svc>) are moved to the
3684 new billing items.  An error is returned if this is not possible (see
3685 L<FS::pkg_svc>).
3686
3687 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3688 newly-created cust_pkg objects.
3689
3690 =cut
3691
3692 sub bulk_change {
3693   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3694
3695   # Transactionize this whole mess
3696   local $SIG{HUP} = 'IGNORE';
3697   local $SIG{INT} = 'IGNORE';
3698   local $SIG{QUIT} = 'IGNORE';
3699   local $SIG{TERM} = 'IGNORE';
3700   local $SIG{TSTP} = 'IGNORE';
3701   local $SIG{PIPE} = 'IGNORE';
3702
3703   my $oldAutoCommit = $FS::UID::AutoCommit;
3704   local $FS::UID::AutoCommit = 0;
3705   my $dbh = dbh;
3706
3707   my @errors;
3708   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3709                          @$remove_pkgnum;
3710
3711   while(scalar(@old_cust_pkg)) {
3712     my @return = ();
3713     my $custnum = $old_cust_pkg[0]->custnum;
3714     my (@remove) = map { $_->pkgnum }
3715                    grep { $_->custnum == $custnum } @old_cust_pkg;
3716     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3717
3718     my $error = order $custnum, $pkgparts, \@remove, \@return;
3719
3720     push @errors, $error
3721       if $error;
3722     push @$return_cust_pkg, @return;
3723   }
3724
3725   if (scalar(@errors)) {
3726     $dbh->rollback if $oldAutoCommit;
3727     return join(' / ', @errors);
3728   }
3729
3730   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3731   '';
3732 }
3733
3734 # Used by FS::Upgrade to migrate to a new database.
3735 sub _upgrade_data {  # class method
3736   my ($class, %opts) = @_;
3737   $class->_upgrade_otaker(%opts);
3738   my @statements = (
3739     # RT#10139, bug resulting in contract_end being set when it shouldn't
3740   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
3741     # RT#10830, bad calculation of prorate date near end of year
3742     # the date range for bill is December 2009, and we move it forward
3743     # one year if it's before the previous bill date (which it should
3744     # never be)
3745   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
3746   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
3747   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
3748     # RT6628, add order_date to cust_pkg
3749     'update cust_pkg set order_date = (select history_date from h_cust_pkg
3750         where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
3751         history_action = \'insert\') where order_date is null',
3752   );
3753   foreach my $sql (@statements) {
3754     my $sth = dbh->prepare($sql);
3755     $sth->execute or die $sth->errstr;
3756   }
3757 }
3758
3759 =back
3760
3761 =head1 BUGS
3762
3763 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
3764
3765 In sub order, the @pkgparts array (passed by reference) is clobbered.
3766
3767 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
3768 method to pass dates to the recur_prog expression, it should do so.
3769
3770 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3771 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3772 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3773 configuration values.  Probably need a subroutine which decides what to do
3774 based on whether or not we've fetched the user yet, rather than a hash.  See
3775 FS::UID and the TODO.
3776
3777 Now that things are transactional should the check in the insert method be
3778 moved to check ?
3779
3780 =head1 SEE ALSO
3781
3782 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3783 L<FS::pkg_svc>, schema.html from the base documentation
3784
3785 =cut
3786
3787 1;
3788