12508e1aa1bdae0f0d142cf9bb749a8e6d5ec8b3
[freeside.git] / FS / FS / cust_pkg.pm
1 package FS::cust_pkg;
2
3 use strict;
4 use vars qw(@ISA);
5 use FS::UID qw( getotaker dbh );
6 use FS::Record qw( qsearch qsearchs );
7 use FS::cust_svc;
8 use FS::part_pkg;
9 use FS::cust_main;
10 use FS::type_pkgs;
11 use FS::pkg_svc;
12
13 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
14 # setup }
15 # because they load configuraion by setting FS::UID::callback (see TODO)
16 use FS::svc_acct;
17 use FS::svc_acct_sm;
18 use FS::svc_domain;
19 use FS::svc_www;
20 use FS::svc_forward;
21
22 @ISA = qw( FS::Record );
23
24 sub _cache {
25   my $self = shift;
26   my ( $hashref, $cache ) = @_;
27   #if ( $hashref->{'pkgpart'} ) {
28   if ( $hashref->{'pkg'} ) {
29     # #@{ $self->{'_pkgnum'} } = ();
30     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
31     # $self->{'_pkgpart'} = $subcache;
32     # #push @{ $self->{'_pkgnum'} },
33     #   FS::part_pkg->new_or_cached($hashref, $subcache);
34     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
35   }
36   if ( exists $hashref->{'svcnum'} ) {
37     #@{ $self->{'_pkgnum'} } = ();
38     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
39     $self->{'_svcnum'} = $subcache;
40     #push @{ $self->{'_pkgnum'} },
41     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
42   }
43 }
44
45 =head1 NAME
46
47 FS::cust_pkg - Object methods for cust_pkg objects
48
49 =head1 SYNOPSIS
50
51   use FS::cust_pkg;
52
53   $record = new FS::cust_pkg \%hash;
54   $record = new FS::cust_pkg { 'column' => 'value' };
55
56   $error = $record->insert;
57
58   $error = $new_record->replace($old_record);
59
60   $error = $record->delete;
61
62   $error = $record->check;
63
64   $error = $record->cancel;
65
66   $error = $record->suspend;
67
68   $error = $record->unsuspend;
69
70   $part_pkg = $record->part_pkg;
71
72   @labels = $record->labels;
73
74   $seconds = $record->seconds_since($timestamp);
75
76   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
77   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
78
79 =head1 DESCRIPTION
80
81 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
82 inherits from FS::Record.  The following fields are currently supported:
83
84 =over 4
85
86 =item pkgnum - primary key (assigned automatically for new billing items)
87
88 =item custnum - Customer (see L<FS::cust_main>)
89
90 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
91
92 =item setup - date
93
94 =item bill - date
95
96 =item susp - date
97
98 =item expire - date
99
100 =item cancel - date
101
102 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
103
104 =item manual_flag - If this field is set to 1, disables the automatic
105 unsuspension of this package when using the B<unsuspendauto> config file.
106
107 =back
108
109 Note: setup, bill, susp, expire and cancel are specified as UNIX timestamps;
110 see L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for
111 conversion functions.
112
113 =head1 METHODS
114
115 =over 4
116
117 =item new HASHREF
118
119 Create a new billing item.  To add the item to the database, see L<"insert">.
120
121 =cut
122
123 sub table { 'cust_pkg'; }
124
125 =item insert
126
127 Adds this billing item to the database ("Orders" the item).  If there is an
128 error, returns the error, otherwise returns false.
129
130 =cut
131
132 sub insert {
133   my $self = shift;
134
135   # custnum might not have have been defined in sub check (for one-shot new
136   # customers), so check it here instead
137   # (is this still necessary with transactions?)
138
139   my $error = $self->ut_number('custnum');
140   return $error if $error;
141
142   my $cust_main = $self->cust_main;
143   return "Unknown customer ". $self->custnum unless $cust_main;
144
145   my $agent = qsearchs( 'agent', { 'agentnum' => $cust_main->agentnum } );
146   my $pkgpart_href = $agent->pkgpart_hashref;
147   return "agent ". $agent->agentnum. " can't purchase pkgpart ". $self->pkgpart
148     unless $pkgpart_href->{ $self->pkgpart };
149
150   $self->SUPER::insert;
151
152 }
153
154 =item delete
155
156 This method now works but you probably shouldn't use it.
157
158 You don't want to delete billing items, because there would then be no record
159 the customer ever purchased the item.  Instead, see the cancel method.
160
161 =cut
162
163 #sub delete {
164 #  return "Can't delete cust_pkg records!";
165 #}
166
167 =item replace OLD_RECORD
168
169 Replaces the OLD_RECORD with this one in the database.  If there is an error,
170 returns the error, otherwise returns false.
171
172 Currently, custnum, setup, bill, susp, expire, and cancel may be changed.
173
174 Changing pkgpart may have disasterous effects.  See the order subroutine.
175
176 setup and bill are normally updated by calling the bill method of a customer
177 object (see L<FS::cust_main>).
178
179 suspend is normally updated by the suspend and unsuspend methods.
180
181 cancel is normally updated by the cancel method (and also the order subroutine
182 in some cases).
183
184 =cut
185
186 sub replace {
187   my( $new, $old ) = ( shift, shift );
188
189   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
190   return "Can't change otaker!" if $old->otaker ne $new->otaker;
191
192   #allow this *sigh*
193   #return "Can't change setup once it exists!"
194   #  if $old->getfield('setup') &&
195   #     $old->getfield('setup') != $new->getfield('setup');
196
197   #some logic for bill, susp, cancel?
198
199   $new->SUPER::replace($old);
200 }
201
202 =item check
203
204 Checks all fields to make sure this is a valid billing item.  If there is an
205 error, returns the error, otherwise returns false.  Called by the insert and
206 replace methods.
207
208 =cut
209
210 sub check {
211   my $self = shift;
212
213   my $error = 
214     $self->ut_numbern('pkgnum')
215     || $self->ut_numbern('custnum')
216     || $self->ut_number('pkgpart')
217     || $self->ut_numbern('setup')
218     || $self->ut_numbern('bill')
219     || $self->ut_numbern('susp')
220     || $self->ut_numbern('cancel')
221   ;
222   return $error if $error;
223
224   if ( $self->custnum ) { 
225     return "Unknown customer ". $self->custnum unless $self->cust_main;
226   }
227
228   return "Unknown pkgpart: ". $self->pkgpart
229     unless qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
230
231   $self->otaker(getotaker) unless $self->otaker;
232   $self->otaker =~ /^([\w\.\-]{0,16})$/ or return "Illegal otaker";
233   $self->otaker($1);
234
235   if ( $self->dbdef_table->column('manual_flag') ) {
236     $self->manual_flag =~ /^([01]?)$/ or return "Illegal manual_flag";
237     $self->manual_flag($1);
238   }
239
240   ''; #no error
241 }
242
243 =item cancel
244
245 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
246 in this package, then cancels the package itself (sets the cancel field to
247 now).
248
249 If there is an error, returns the error, otherwise returns false.
250
251 =cut
252
253 sub cancel {
254   my $self = shift;
255   my $error;
256
257   local $SIG{HUP} = 'IGNORE';
258   local $SIG{INT} = 'IGNORE';
259   local $SIG{QUIT} = 'IGNORE'; 
260   local $SIG{TERM} = 'IGNORE';
261   local $SIG{TSTP} = 'IGNORE';
262   local $SIG{PIPE} = 'IGNORE';
263
264   my $oldAutoCommit = $FS::UID::AutoCommit;
265   local $FS::UID::AutoCommit = 0;
266   my $dbh = dbh;
267
268   foreach my $cust_svc (
269     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
270   ) {
271     my $error = $cust_svc->cancel;
272
273     if ( $error ) {
274       $dbh->rollback if $oldAutoCommit;
275       return "Error cancelling cust_svc: $error";
276     }
277
278   }
279
280   unless ( $self->getfield('cancel') ) {
281     my %hash = $self->hash;
282     $hash{'cancel'} = time;
283     my $new = new FS::cust_pkg ( \%hash );
284     $error = $new->replace($self);
285     if ( $error ) {
286       $dbh->rollback if $oldAutoCommit;
287       return $error;
288     }
289   }
290
291   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
292
293   ''; #no errors
294 }
295
296 =item suspend
297
298 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
299 package, then suspends the package itself (sets the susp field to now).
300
301 If there is an error, returns the error, otherwise returns false.
302
303 =cut
304
305 sub suspend {
306   my $self = shift;
307   my $error ;
308
309   local $SIG{HUP} = 'IGNORE';
310   local $SIG{INT} = 'IGNORE';
311   local $SIG{QUIT} = 'IGNORE'; 
312   local $SIG{TERM} = 'IGNORE';
313   local $SIG{TSTP} = 'IGNORE';
314   local $SIG{PIPE} = 'IGNORE';
315
316   my $oldAutoCommit = $FS::UID::AutoCommit;
317   local $FS::UID::AutoCommit = 0;
318   my $dbh = dbh;
319
320   foreach my $cust_svc (
321     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
322   ) {
323     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
324
325     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
326       $dbh->rollback if $oldAutoCommit;
327       return "Illegal svcdb value in part_svc!";
328     };
329     my $svcdb = $1;
330     require "FS/$svcdb.pm";
331
332     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
333     if ($svc) {
334       $error = $svc->suspend;
335       if ( $error ) {
336         $dbh->rollback if $oldAutoCommit;
337         return $error;
338       }
339     }
340
341   }
342
343   unless ( $self->getfield('susp') ) {
344     my %hash = $self->hash;
345     $hash{'susp'} = time;
346     my $new = new FS::cust_pkg ( \%hash );
347     $error = $new->replace($self);
348     if ( $error ) {
349       $dbh->rollback if $oldAutoCommit;
350       return $error;
351     }
352   }
353
354   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
355
356   ''; #no errors
357 }
358
359 =item unsuspend
360
361 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
362 package, then unsuspends the package itself (clears the susp field).
363
364 If there is an error, returns the error, otherwise returns false.
365
366 =cut
367
368 sub unsuspend {
369   my $self = shift;
370   my($error);
371
372   local $SIG{HUP} = 'IGNORE';
373   local $SIG{INT} = 'IGNORE';
374   local $SIG{QUIT} = 'IGNORE'; 
375   local $SIG{TERM} = 'IGNORE';
376   local $SIG{TSTP} = 'IGNORE';
377   local $SIG{PIPE} = 'IGNORE';
378
379   my $oldAutoCommit = $FS::UID::AutoCommit;
380   local $FS::UID::AutoCommit = 0;
381   my $dbh = dbh;
382
383   foreach my $cust_svc (
384     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
385   ) {
386     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
387
388     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
389       $dbh->rollback if $oldAutoCommit;
390       return "Illegal svcdb value in part_svc!";
391     };
392     my $svcdb = $1;
393     require "FS/$svcdb.pm";
394
395     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
396     if ($svc) {
397       $error = $svc->unsuspend;
398       if ( $error ) {
399         $dbh->rollback if $oldAutoCommit;
400         return $error;
401       }
402     }
403
404   }
405
406   unless ( ! $self->getfield('susp') ) {
407     my %hash = $self->hash;
408     $hash{'susp'} = '';
409     my $new = new FS::cust_pkg ( \%hash );
410     $error = $new->replace($self);
411     if ( $error ) {
412       $dbh->rollback if $oldAutoCommit;
413       return $error;
414     }
415   }
416
417   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
418
419   ''; #no errors
420 }
421
422 =item part_pkg
423
424 Returns the definition for this billing item, as an FS::part_pkg object (see
425 L<FS::part_pkg>).
426
427 =cut
428
429 sub part_pkg {
430   my $self = shift;
431   #exists( $self->{'_pkgpart'} )
432   $self->{'_pkgpart'}
433     ? $self->{'_pkgpart'}
434     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
435 }
436
437 =item cust_svc
438
439 Returns the services for this package, as FS::cust_svc objects (see
440 L<FS::cust_svc>)
441
442 =cut
443
444 sub cust_svc {
445   my $self = shift;
446   if ( $self->{'_svcnum'} ) {
447     values %{ $self->{'_svcnum'}->cache };
448   } else {
449     qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } );
450   }
451 }
452
453 =item labels
454
455 Returns a list of lists, calling the label method for all services
456 (see L<FS::cust_svc>) of this billing item.
457
458 =cut
459
460 sub labels {
461   my $self = shift;
462   map { [ $_->label ] } $self->cust_svc;
463 }
464
465 =item cust_main
466
467 Returns the parent customer object (see L<FS::cust_main>).
468
469 =cut
470
471 sub cust_main {
472   my $self = shift;
473   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
474 }
475
476 =item seconds_since TIMESTAMP
477
478 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
479 package have been online since TIMESTAMP.
480
481 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
482 L<Time::Local> and L<Date::Parse> for conversion functions.
483
484 =cut
485
486 sub seconds_since {
487   my($self, $since) = @_;
488   my $seconds = 0;
489
490   foreach my $cust_svc (
491     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
492   ) {
493     $seconds += $cust_svc->seconds_since($since);
494   }
495
496   $seconds;
497
498 }
499
500 =back
501
502 =head1 SUBROUTINES
503
504 =over 4
505
506 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
507
508 CUSTNUM is a customer (see L<FS::cust_main>)
509
510 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
511 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
512 permitted.
513
514 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
515 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
516 new billing items.  An error is returned if this is not possible (see
517 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
518 parameter.
519
520 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
521 newly-created cust_pkg objects.
522
523 =cut
524
525 sub order {
526   my($custnum, $pkgparts, $remove_pkgnums, $return_cust_pkg) = @_;
527   $remove_pkgnums = [] unless defined($remove_pkgnums);
528
529   my $oldAutoCommit = $FS::UID::AutoCommit;
530   local $FS::UID::AutoCommit = 0;
531   my $dbh = dbh;
532
533   # generate %part_pkg
534   # $part_pkg{$pkgpart} is true iff $custnum may purchase $pkgpart
535   #
536   my($cust_main)=qsearchs('cust_main',{'custnum'=>$custnum});
537   my($agent)=qsearchs('agent',{'agentnum'=> $cust_main->agentnum });
538   my %part_pkg = %{ $agent->pkgpart_hashref };
539
540   my(%svcnum);
541   # generate %svcnum
542   # for those packages being removed:
543   #@{ $svcnum{$svcpart} } goes from a svcpart to a list of FS::cust_svc objects
544   my($pkgnum);
545   foreach $pkgnum ( @{$remove_pkgnums} ) {
546     foreach my $cust_svc (qsearch('cust_svc',{'pkgnum'=>$pkgnum})) {
547       push @{ $svcnum{$cust_svc->getfield('svcpart')} }, $cust_svc;
548     }
549   }
550   
551   my @cust_svc;
552   #generate @cust_svc
553   # for those packages the customer is purchasing:
554   # @{$pkgparts} is a list of said packages, by pkgpart
555   # @cust_svc is a corresponding list of lists of FS::Record objects
556   foreach my $pkgpart ( @{$pkgparts} ) {
557     unless ( $part_pkg{$pkgpart} ) {
558       $dbh->rollback if $oldAutoCommit;
559       return "Customer not permitted to purchase pkgpart $pkgpart!";
560     }
561     push @cust_svc, [
562       map {
563         ( $svcnum{$_} && @{ $svcnum{$_} } ) ? shift @{ $svcnum{$_} } : ();
564       } map { $_->svcpart }
565           qsearch('pkg_svc', { pkgpart  => $pkgpart,
566                                quantity => { op=>'>', value=>'0', } } )
567     ];
568   }
569
570   #special-case until this can be handled better
571   # move services to new svcparts - even if the svcparts don't match (svcdb
572   # needs to...)
573   # looks like they're moved in no particular order, ewwwwwwww
574   # and looks like just one of each svcpart can be moved... o well
575
576   #start with still-leftover services
577   #foreach my $svcpart ( grep { scalar(@{ $svcnum{$_} }) } keys %svcnum ) {
578   foreach my $svcpart ( keys %svcnum ) {
579     next unless @{ $svcnum{$svcpart} };
580
581     my $svcdb = $svcnum{$svcpart}->[0]->part_svc->svcdb;
582
583     #find an empty place to put one
584     my $i = 0;
585     foreach my $pkgpart ( @{$pkgparts} ) {
586       my @pkg_svc =
587         qsearch('pkg_svc', { pkgpart  => $pkgpart,
588                              quantity => { op=>'>', value=>'0', } } );
589       #my @pkg_svc =
590       #  grep { $_->quantity > 0 } qsearch('pkg_svc', { pkgpart=>$pkgpart } );
591       if ( ! @{$cust_svc[$i]} #find an empty place to put them with 
592            && grep { $svcdb eq $_->part_svc->svcdb } #with appropriate svcdb
593                 @pkg_svc
594       ) {
595         my $new_svcpart =
596           ( grep { $svcdb eq $_->part_svc->svcdb } @pkg_svc )[0]->svcpart; 
597         my $cust_svc = shift @{$svcnum{$svcpart}};
598         $cust_svc->svcpart($new_svcpart);
599         #warn "changing from $svcpart to $new_svcpart!!!\n";
600         $cust_svc[$i] = [ $cust_svc ];
601       }
602       $i++;
603     }
604
605   }
606   
607   #check for leftover services
608   foreach (keys %svcnum) {
609     next unless @{ $svcnum{$_} };
610     $dbh->rollback if $oldAutoCommit;
611     return "Leftover services, svcpart $_: svcnum ".
612            join(', ', map { $_->svcnum } @{ $svcnum{$_} } );
613   }
614
615   #no leftover services, let's make changes.
616  
617   local $SIG{HUP} = 'IGNORE';
618   local $SIG{INT} = 'IGNORE'; 
619   local $SIG{QUIT} = 'IGNORE';
620   local $SIG{TERM} = 'IGNORE';
621   local $SIG{TSTP} = 'IGNORE'; 
622   local $SIG{PIPE} = 'IGNORE'; 
623
624   #first cancel old packages
625   foreach my $pkgnum ( @{$remove_pkgnums} ) {
626     my($old) = qsearchs('cust_pkg',{'pkgnum'=>$pkgnum});
627     unless ( $old ) {
628       $dbh->rollback if $oldAutoCommit;
629       return "Package $pkgnum not found to remove!";
630     }
631     my(%hash) = $old->hash;
632     $hash{'cancel'}=time;   
633     my($new) = new FS::cust_pkg ( \%hash );
634     my($error)=$new->replace($old);
635     if ( $error ) {
636       $dbh->rollback if $oldAutoCommit;
637       return "Couldn't update package $pkgnum: $error";
638     }
639   }
640
641   #now add new packages, changing cust_svc records if necessary
642   my $pkgpart;
643   while ($pkgpart=shift @{$pkgparts} ) {
644  
645     my $new = new FS::cust_pkg {
646                                  'custnum' => $custnum,
647                                  'pkgpart' => $pkgpart,
648                                };
649     my $error = $new->insert;
650     if ( $error ) {
651       $dbh->rollback if $oldAutoCommit;
652       return "Couldn't insert new cust_pkg record: $error";
653     }
654     push @{$return_cust_pkg}, $new if $return_cust_pkg;
655     my $pkgnum = $new->pkgnum;
656  
657     foreach my $cust_svc ( @{ shift @cust_svc } ) {
658       my(%hash) = $cust_svc->hash;
659       $hash{'pkgnum'}=$pkgnum;
660       my $new = new FS::cust_svc ( \%hash );
661
662       #avoid Record diffing missing changed svcpart field from above.
663       my $old = qsearchs('cust_svc', { 'svcnum' => $cust_svc->svcnum } );
664
665       my $error = $new->replace($old);
666       if ( $error ) {
667         $dbh->rollback if $oldAutoCommit;
668         return "Couldn't link old service to new package: $error";
669       }
670     }
671   }  
672
673   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
674
675   ''; #no errors
676 }
677
678 =back
679
680 =head1 VERSION
681
682 $Id: cust_pkg.pm,v 1.23 2002-08-26 20:40:55 ivan Exp $
683
684 =head1 BUGS
685
686 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
687
688 In sub order, the @pkgparts array (passed by reference) is clobbered.
689
690 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
691 method to pass dates to the recur_prog expression, it should do so.
692
693 FS::svc_acct, FS::svc_acct_sm, and FS::svc_domain are loaded via 'use' at 
694 compile time, rather than via 'require' in sub { setup, suspend, unsuspend,
695 cancel } because they use %FS::UID::callback to load configuration values.
696 Probably need a subroutine which decides what to do based on whether or not
697 we've fetched the user yet, rather than a hash.  See FS::UID and the TODO.
698
699 Now that things are transactional should the check in the insert method be
700 moved to check ?
701
702 =head1 SEE ALSO
703
704 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
705 L<FS::pkg_svc>, schema.html from the base documentation
706
707 =cut
708
709 1;
710