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