FS/FS/cust_main/Packages.pm

   1 package FS::cust_main::Packages;
   2
   3 use strict;
   4 use vars qw( $DEBUG $me );
   5 use List::Util qw( min );
   6 use FS::UID qw( dbh );
   7 use FS::Record qw( qsearch );
   8 use FS::cust_pkg;
   9 use FS::cust_svc;
  10
  11 $DEBUG = 0;
  12 $me = '[FS::cust_main::Packages]';
  13
  14 =head1 NAME
  15
  16 FS::cust_main::Packages - Packages mixin for cust_main
  17
  18 =head1 SYNOPSIS
  19
  20 =head1 DESCRIPTION
  21
  22 These methods are available on FS::cust_main objects;
  23
  24 =head1 METHODS
  25
  26 =over 4
  27
  28 =item order_pkg HASHREF | OPTION => VALUE ...
  29
  30 Orders a single package.
  31
  32 Note that if the package definition has supplemental packages, those will
  33 be ordered as well.
  34
  35 Options may be passed as a list of key/value pairs or as a hash reference.
  36 Options are:
  37
  38 =over 4
  39
  40 =item cust_pkg
  41
  42 FS::cust_pkg object
  43
  44 =item cust_location
  45
  46 Optional FS::cust_location object.  If not specified, the customer's
  47 ship_location will be used.
  48
  49 =item svcs
  50
  51 Optional arryaref of FS::svc_* service objects.
  52
  53 =item depend_jobnum
  54
  55 If this option is set to a job queue jobnum (see L<FS::queue>), all provisioning
  56 jobs will have a dependancy on the supplied job (they will not run until the
  57 specific job completes).  This can be used to defer provisioning until some
  58 action completes (such as running the customer's credit card successfully).
  59
  60 =item ticket_subject
  61
  62 Optional subject for a ticket created and attached to this customer
  63
  64 =item ticket_queue
  65
  66 Optional queue name for ticket additions
  67
  68 =back
  69
  70 =cut
  71
  72 sub order_pkg {
  73   my $self = shift;
  74   my $opt = ref($_[0]) ? shift : { @_ };
  75
  76   local($DEBUG) = $FS::cust_main::DEBUG if $FS::cust_main::DEBUG > $DEBUG;
  77
  78   warn "$me order_pkg called with options ".
  79        join(', ', map { "$_: $opt->{$_}" } keys %$opt ). "\n"
  80     if $DEBUG;
  81
  82   my $cust_pkg = $opt->{'cust_pkg'};
  83   my $svcs     = $opt->{'svcs'} || [];
  84
  85   my %svc_options = ();
  86   $svc_options{'depend_jobnum'} = $opt->{'depend_jobnum'}
  87     if exists($opt->{'depend_jobnum'}) && $opt->{'depend_jobnum'};
  88
  89   my %insert_params = map { $opt->{$_} ? ( $_ => $opt->{$_} ) : () }
  90                           qw( ticket_subject ticket_queue );
  91
  92   local $SIG{HUP} = 'IGNORE';
  93   local $SIG{INT} = 'IGNORE';
  94   local $SIG{QUIT} = 'IGNORE';
  95   local $SIG{TERM} = 'IGNORE';
  96   local $SIG{TSTP} = 'IGNORE';
  97   local $SIG{PIPE} = 'IGNORE';
  98
  99   my $oldAutoCommit = $FS::UID::AutoCommit;
 100   local $FS::UID::AutoCommit = 0;
 101   my $dbh = dbh;
 102
 103   if ( $opt->{'locationnum'} and $opt->{'locationnum'} != -1 ) {
 104
 105     $cust_pkg->locationnum($opt->{'locationnum'});
 106
 107   } elsif ( $opt->{'cust_location'} ) {
 108
 109     if ( ! $opt->{'cust_location'}->locationnum ) {
 110       # not inserted yet
 111       my $error = $opt->{'cust_location'}->insert;
 112       if ( $error ) {
 113         $dbh->rollback if $oldAutoCommit;
 114         return "inserting cust_location (transaction rolled back): $error";
 115       }
 116     }
 117     $cust_pkg->locationnum($opt->{'cust_location'}->locationnum);
 118
 119   } else {
 120
 121     $cust_pkg->locationnum($self->ship_locationnum);
 122
 123   }
 124
 125   $cust_pkg->custnum( $self->custnum );
 126
 127   my $error = $cust_pkg->insert( %insert_params );
 128   if ( $error ) {
 129     $dbh->rollback if $oldAutoCommit;
 130     return "inserting cust_pkg (transaction rolled back): $error";
 131   }
 132
 133   foreach my $svc_something ( @{ $opt->{'svcs'} } ) {
 134     if ( $svc_something->svcnum ) {
 135       my $old_cust_svc = $svc_something->cust_svc;
 136       my $new_cust_svc = new FS::cust_svc { $old_cust_svc->hash };
 137       $new_cust_svc->pkgnum( $cust_pkg->pkgnum);
 138       $error = $new_cust_svc->replace($old_cust_svc);
 139     } else {
 140       $svc_something->pkgnum( $cust_pkg->pkgnum );
 141       if ( $svc_something->isa('FS::svc_acct') ) {
 142         foreach ( grep { $opt->{$_.'_ref'} && ${ $opt->{$_.'_ref'} } }
 143                        qw( seconds upbytes downbytes totalbytes )      ) {
 144           $svc_something->$_( $svc_something->$_() + ${ $opt->{$_.'_ref'} } );
 145           ${ $opt->{$_.'_ref'} } = 0;
 146         }
 147       }
 148       $error = $svc_something->insert(%svc_options);
 149     }
 150     if ( $error ) {
 151       $dbh->rollback if $oldAutoCommit;
 152       return "inserting svc_ (transaction rolled back): $error";
 153     }
 154   }
 155
 156   # add supplemental packages, if any are needed
 157   my $part_pkg = FS::part_pkg->by_key($cust_pkg->pkgpart);
 158   foreach my $link ($part_pkg->supp_part_pkg_link) {
 159     #warn "inserting supplemental package ".$link->dst_pkgpart;
 160     my $pkg = FS::cust_pkg->new({
 161         'pkgpart'       => $link->dst_pkgpart,
 162         'pkglinknum'    => $link->pkglinknum,
 163         'custnum'       => $self->custnum,
 164         'main_pkgnum'   => $cust_pkg->pkgnum,
 165         'locationnum'   => $cust_pkg->locationnum,
 166         # try to prevent as many surprises as possible
 167         'pkgbatch'      => $cust_pkg->pkgbatch,
 168         'start_date'    => $cust_pkg->start_date,
 169         'order_date'    => $cust_pkg->order_date,
 170         'expire'        => $cust_pkg->expire,
 171         'adjourn'       => $cust_pkg->adjourn,
 172         'contract_end'  => $cust_pkg->contract_end,
 173         'refnum'        => $cust_pkg->refnum,
 174         'discountnum'   => $cust_pkg->discountnum,
 175         'waive_setup'   => $cust_pkg->waive_setup,
 176     });
 177     $error = $self->order_pkg('cust_pkg' => $pkg);
 178     if ( $error ) {
 179       $dbh->rollback if $oldAutoCommit;
 180       return "inserting supplemental package: $error";
 181     }
 182   }
 183
 184   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 185   ''; #no error
 186
 187 }
 188
 189 =item order_pkgs HASHREF [ , OPTION => VALUE ... ]
 190
 191 Like the insert method on an existing record, this method orders multiple
 192 packages and included services atomicaly.  Pass a Tie::RefHash data structure
 193 to this method containing FS::cust_pkg and FS::svc_I<tablename> objects.
 194 There should be a better explanation of this, but until then, here's an
 195 example:
 196
 197   use Tie::RefHash;
 198   tie %hash, 'Tie::RefHash'; #this part is important
 199   %hash = (
 200     $cust_pkg => [ $svc_acct ],
 201     ...
 202   );
 203   $cust_main->order_pkgs( \%hash, 'noexport'=>1 );
 204
 205 Services can be new, in which case they are inserted, or existing unaudited
 206 services, in which case they are linked to the newly-created package.
 207
 208 Currently available options are: I<depend_jobnum>, I<noexport>, I<seconds_ref>,
 209 I<upbytes_ref>, I<downbytes_ref>, and I<totalbytes_ref>.
 210
 211 If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
 212 on the supplied jobnum (they will not run until the specific job completes).
 213 This can be used to defer provisioning until some action completes (such
 214 as running the customer's credit card successfully).
 215
 216 The I<noexport> option is deprecated.  If I<noexport> is set true, no
 217 provisioning jobs (exports) are scheduled.  (You can schedule them later with
 218 the B<reexport> method for each cust_pkg object.  Using the B<reexport> method
 219 on the cust_main object is not recommended, as existing services will also be
 220 reexported.)
 221
 222 If I<seconds_ref>, I<upbytes_ref>, I<downbytes_ref>, or I<totalbytes_ref> is
 223 provided, the scalars (provided by references) will be incremented by the
 224 values of the prepaid card.`
 225
 226 =cut
 227
 228 sub order_pkgs {
 229   my $self = shift;
 230   my $cust_pkgs = shift;
 231   my %options = @_;
 232
 233   local($DEBUG) = $FS::cust_main::DEBUG if $FS::cust_main::DEBUG > $DEBUG;
 234
 235   warn "$me order_pkgs called with options ".
 236        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 237     if $DEBUG;
 238
 239   local $SIG{HUP} = 'IGNORE';
 240   local $SIG{INT} = 'IGNORE';
 241   local $SIG{QUIT} = 'IGNORE';
 242   local $SIG{TERM} = 'IGNORE';
 243   local $SIG{TSTP} = 'IGNORE';
 244   local $SIG{PIPE} = 'IGNORE';
 245
 246   my $oldAutoCommit = $FS::UID::AutoCommit;
 247   local $FS::UID::AutoCommit = 0;
 248   my $dbh = dbh;
 249
 250   local $FS::svc_Common::noexport_hack = 1 if $options{'noexport'};
 251
 252   foreach my $cust_pkg ( keys %$cust_pkgs ) {
 253
 254     my $error = $self->order_pkg(
 255       'cust_pkg'     => $cust_pkg,
 256       'svcs'         => $cust_pkgs->{$cust_pkg},
 257       map { $_ => $options{$_} }
 258         qw( seconds_ref upbytes_ref downbytes_ref totalbytes_ref depend_jobnum )
 259     );
 260     if ( $error ) {
 261       $dbh->rollback if $oldAutoCommit;
 262       return $error;
 263     }
 264
 265   }
 266
 267   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 268   ''; #no error
 269 }
 270
 271 =item all_pkgs [ OPTION => VALUE... | EXTRA_QSEARCH_PARAMS_HASHREF ]
 272
 273 Returns all packages (see L<FS::cust_pkg>) for this customer.
 274
 275 =cut
 276
 277 sub all_pkgs {
 278   my $self = shift;
 279   my $extra_qsearch = ref($_[0]) ? shift : { @_ };
 280
 281   return $self->num_pkgs unless wantarray || keys %$extra_qsearch;
 282
 283   my @cust_pkg = ();
 284   if ( $self->{'_pkgnum'} && ! keys %$extra_qsearch ) {
 285     @cust_pkg = values %{ $self->{'_pkgnum'}->cache };
 286   } else {
 287     @cust_pkg = $self->_cust_pkg($extra_qsearch);
 288   }
 289
 290   map { $_ } sort sort_packages @cust_pkg;
 291 }
 292
 293 =item cust_pkg
 294
 295 Synonym for B<all_pkgs>.
 296
 297 =cut
 298
 299 sub cust_pkg {
 300   shift->all_pkgs(@_);
 301 }
 302
 303 =item ncancelled_pkgs [ EXTRA_QSEARCH_PARAMS_HASHREF ]
 304
 305 Returns all non-cancelled packages (see L<FS::cust_pkg>) for this customer.
 306
 307 =cut
 308
 309 sub ncancelled_pkgs {
 310   my $self = shift;
 311   my $extra_qsearch = ref($_[0]) ? shift : {};
 312
 313   local($DEBUG) = $FS::cust_main::DEBUG if $FS::cust_main::DEBUG > $DEBUG;
 314
 315   return $self->num_ncancelled_pkgs unless wantarray;
 316
 317   my @cust_pkg = ();
 318   if ( $self->{'_pkgnum'} ) {
 319
 320     warn "$me ncancelled_pkgs: returning cached objects"
 321       if $DEBUG > 1;
 322
 323     @cust_pkg = grep { ! $_->getfield('cancel') }
 324                 values %{ $self->{'_pkgnum'}->cache };
 325
 326   } else {
 327
 328     warn "$me ncancelled_pkgs: searching for packages with custnum ".
 329          $self->custnum. "\n"
 330       if $DEBUG > 1;
 331
 332     $extra_qsearch->{'extra_sql'} .= ' AND ( cancel IS NULL OR cancel = 0 ) ';
 333
 334     @cust_pkg = $self->_cust_pkg($extra_qsearch);
 335
 336   }
 337
 338   sort sort_packages @cust_pkg;
 339
 340 }
 341
 342 sub _cust_pkg {
 343   my $self = shift;
 344   my $extra_qsearch = ref($_[0]) ? shift : {};
 345
 346   $extra_qsearch->{'select'} ||= '*';
 347   $extra_qsearch->{'select'} .=
 348    ',( SELECT COUNT(*) FROM cust_svc WHERE cust_pkg.pkgnum = cust_svc.pkgnum )
 349      AS _num_cust_svc';
 350
 351   map {
 352         $_->{'_num_cust_svc'} = $_->get('_num_cust_svc');
 353         $_;
 354       }
 355   qsearch({
 356     %$extra_qsearch,
 357     'table'   => 'cust_pkg',
 358     'hashref' => { 'custnum' => $self->custnum },
 359   });
 360
 361 }
 362
 363 # This should be generalized to use config options to determine order.
 364 sub sort_packages {
 365
 366   my $locationsort = ( $a->locationnum || 0 ) <=> ( $b->locationnum || 0 );
 367   return $locationsort if $locationsort;
 368
 369   if ( $a->get('cancel') xor $b->get('cancel') ) {
 370     return -1 if $b->get('cancel');
 371     return  1 if $a->get('cancel');
 372     #shouldn't get here...
 373     return 0;
 374   } else {
 375     my $a_num_cust_svc = $a->num_cust_svc;
 376     my $b_num_cust_svc = $b->num_cust_svc;
 377     return 0  if !$a_num_cust_svc && !$b_num_cust_svc;
 378     return -1 if  $a_num_cust_svc && !$b_num_cust_svc;
 379     return 1  if !$a_num_cust_svc &&  $b_num_cust_svc;
 380     my @a_cust_svc = $a->cust_svc;
 381     my @b_cust_svc = $b->cust_svc;
 382     return 0  if !scalar(@a_cust_svc) && !scalar(@b_cust_svc);
 383     return -1 if  scalar(@a_cust_svc) && !scalar(@b_cust_svc);
 384     return 1  if !scalar(@a_cust_svc) &&  scalar(@b_cust_svc);
 385     $a_cust_svc[0]->svc_x->label cmp $b_cust_svc[0]->svc_x->label;
 386   }
 387
 388 }
 389
 390 =item suspended_pkgs
 391
 392 Returns all suspended packages (see L<FS::cust_pkg>) for this customer.
 393
 394 =cut
 395
 396 sub suspended_pkgs {
 397   my $self = shift;
 398   return $self->num_suspended_pkgs unless wantarray;
 399   grep { $_->susp } $self->ncancelled_pkgs;
 400 }
 401
 402 =item unflagged_suspended_pkgs
 403
 404 Returns all unflagged suspended packages (see L<FS::cust_pkg>) for this
 405 customer (thouse packages without the `manual_flag' set).
 406
 407 =cut
 408
 409 sub unflagged_suspended_pkgs {
 410   my $self = shift;
 411   return $self->suspended_pkgs
 412     unless dbdef->table('cust_pkg')->column('manual_flag');
 413   grep { ! $_->manual_flag } $self->suspended_pkgs;
 414 }
 415
 416 =item unsuspended_pkgs
 417
 418 Returns all unsuspended (and uncancelled) packages (see L<FS::cust_pkg>) for
 419 this customer.
 420
 421 =cut
 422
 423 sub unsuspended_pkgs {
 424   my $self = shift;
 425   return $self->num_unsuspended_pkgs unless wantarray;
 426   grep { ! $_->susp } $self->ncancelled_pkgs;
 427 }
 428
 429 =item active_pkgs
 430
 431 Returns all unsuspended (and uncancelled) packages (see L<FS::cust_pkg>) for
 432 this customer that are active (recurring).
 433
 434 =cut
 435
 436 sub active_pkgs {
 437   my $self = shift;
 438   grep { my $part_pkg = $_->part_pkg;
 439          $part_pkg->freq ne '' && $part_pkg->freq ne '0';
 440        }
 441        $self->unsuspended_pkgs;
 442 }
 443
 444 =item billing_pkgs
 445
 446 Returns active packages, and also any suspended packages which are set to
 447 continue billing while suspended.
 448
 449 =cut
 450
 451 sub billing_pkgs {
 452   my $self = shift;
 453   grep { my $part_pkg = $_->part_pkg;
 454          $part_pkg->freq ne '' && $part_pkg->freq ne '0'
 455            && ( ! $_->susp || $_->option('suspend_bill',1)
 456                            || ( $part_pkg->option('suspend_bill', 1)
 457                                   && ! $_->option('no_suspend_bill',1)
 458                               )
 459               );
 460        }
 461        $self->ncancelled_pkgs;
 462 }
 463
 464 =item next_bill_date
 465
 466 Returns the next date this customer will be billed, as a UNIX timestamp, or
 467 undef if no billing package has a next bill date.
 468
 469 =cut
 470
 471 sub next_bill_date {
 472   my $self = shift;
 473   min( map $_->get('bill'), grep $_->get('bill'), $self->billing_pkgs );
 474 }
 475
 476 =item num_cancelled_pkgs
 477
 478 Returns the number of cancelled packages (see L<FS::cust_pkg>) for this
 479 customer.
 480
 481 =cut
 482
 483 sub num_cancelled_pkgs {
 484   shift->num_pkgs("cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0");
 485 }
 486
 487 sub num_ncancelled_pkgs {
 488   shift->num_pkgs("( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )");
 489 }
 490
 491 sub num_suspended_pkgs {
 492   shift->num_pkgs("     ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
 493                     AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0   ");
 494 }
 495
 496 sub num_unsuspended_pkgs {
 497   shift->num_pkgs("     ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
 498                     AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 ) ");
 499 }
 500
 501 sub num_pkgs {
 502   my( $self ) = shift;
 503   my $sql = scalar(@_) ? shift : '';
 504   $sql = "AND $sql" if $sql && $sql !~ /^\s*$/ && $sql !~ /^\s*AND/i;
 505   my $sth = dbh->prepare(
 506     "SELECT COUNT(*) FROM cust_pkg WHERE custnum = ? $sql"
 507   ) or die dbh->errstr;
 508   $sth->execute($self->custnum) or die $sth->errstr;
 509   $sth->fetchrow_arrayref->[0];
 510 }
 511
 512 =back
 513
 514 =head1 BUGS
 515
 516 =head1 SEE ALSO
 517
 518 L<FS::cust_main>, L<FS::cust_pkg>
 519
 520 =cut
 521
 522 1;
 523