FS/FS/cust_pkg.pm

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