FS/FS/cust_main/Packages.pm

   1 package FS::cust_main::Packages;
   2
   3 use strict;
   4 use vars qw( $DEBUG $me $skip_label_sort );
   5 use List::Util qw( min );
   6 use FS::UID qw( dbh );
   7 use FS::Record qw( qsearch qsearchs );
   8 use FS::cust_pkg;
   9 use FS::cust_svc;
  10 use FS::contact;       # for attach_pkgs
  11 use FS::cust_location; #
  12
  13 $DEBUG = 0;
  14 $me = '[FS::cust_main::Packages]';
  15 $skip_label_sort = 0;
  16
  17 =head1 NAME
  18
  19 FS::cust_main::Packages - Packages mixin for cust_main
  20
  21 =head1 SYNOPSIS
  22
  23 =head1 DESCRIPTION
  24
  25 These methods are available on FS::cust_main objects;
  26
  27 =head1 METHODS
  28
  29 =over 4
  30
  31 =item order_pkg HASHREF | OPTION => VALUE ...
  32
  33 Orders a single package.
  34
  35 Note that if the package definition has supplemental packages, those will
  36 be ordered as well.
  37
  38 Options may be passed as a list of key/value pairs or as a hash reference.
  39 Options are:
  40
  41 =over 4
  42
  43 =item cust_pkg
  44
  45 FS::cust_pkg object
  46
  47 =item cust_location
  48
  49 Optional FS::cust_location object.  If not specified, the customer's
  50 ship_location will be used.
  51
  52 =item svcs
  53
  54 Optional arryaref of FS::svc_* service objects.
  55
  56 =item depend_jobnum
  57
  58 If this option is set to a job queue jobnum (see L<FS::queue>), all provisioning
  59 jobs will have a dependancy on the supplied job (they will not run until the
  60 specific job completes).  This can be used to defer provisioning until some
  61 action completes (such as running the customer's credit card successfully).
  62
  63 =item noexport
  64
  65 This option is option is deprecated but still works for now (use
  66 I<depend_jobnum> instead for new code).  If I<noexport> is set true, no
  67 provisioning jobs (exports) are scheduled.  (You can schedule them later with
  68 the B<reexport> method for each cust_pkg object.  Using the B<reexport> method
  69 on the cust_main object is not recommended, as existing services will also be
  70 reexported.)
  71
  72 =item ticket_subject
  73
  74 Optional subject for a ticket created and attached to this customer
  75
  76 =item ticket_queue
  77
  78 Optional queue name for ticket additions
  79
  80 =back
  81
  82 =cut
  83
  84 sub order_pkg {
  85   my $self = shift;
  86   my $opt = ref($_[0]) ? shift : { @_ };
  87
  88   local($DEBUG) = $FS::cust_main::DEBUG if $FS::cust_main::DEBUG > $DEBUG;
  89
  90   warn "$me order_pkg called with options ".
  91        join(', ', map { "$_: $opt->{$_}" } keys %$opt ). "\n"
  92     if $DEBUG;
  93
  94   local $FS::svc_Common::noexport_hack = 1 if $opt->{'noexport'};
  95
  96   my $cust_pkg = $opt->{'cust_pkg'};
  97   my $svcs     = $opt->{'svcs'} || [];
  98
  99   my %svc_options = ();
 100   $svc_options{'depend_jobnum'} = $opt->{'depend_jobnum'}
 101     if exists($opt->{'depend_jobnum'}) && $opt->{'depend_jobnum'};
 102
 103   my %insert_params = map { $opt->{$_} ? ( $_ => $opt->{$_} ) : () }
 104                           qw( ticket_subject ticket_queue allow_pkgpart );
 105
 106   local $SIG{HUP} = 'IGNORE';
 107   local $SIG{INT} = 'IGNORE';
 108   local $SIG{QUIT} = 'IGNORE';
 109   local $SIG{TERM} = 'IGNORE';
 110   local $SIG{TSTP} = 'IGNORE';
 111   local $SIG{PIPE} = 'IGNORE';
 112
 113   my $oldAutoCommit = $FS::UID::AutoCommit;
 114   local $FS::UID::AutoCommit = 0;
 115   my $dbh = dbh;
 116
 117   if ( $opt->{'contactnum'} and $opt->{'contactnum'} != -1 ) {
 118
 119     $cust_pkg->contactnum($opt->{'contactnum'});
 120
 121   } elsif ( $opt->{'contact'} ) {
 122
 123     if ( ! $opt->{'contact'}->contactnum ) {
 124       # not inserted yet
 125       my $error = $opt->{'contact'}->insert;
 126       if ( $error ) {
 127         $dbh->rollback if $oldAutoCommit;
 128         return "inserting contact (transaction rolled back): $error";
 129       }
 130     }
 131     $cust_pkg->contactnum($opt->{'contact'}->contactnum);
 132
 133   #} else {
 134   #
 135   #  $cust_pkg->contactnum();
 136
 137   }
 138
 139   if ( $opt->{'locationnum'} and $opt->{'locationnum'} != -1 ) {
 140
 141     $cust_pkg->locationnum($opt->{'locationnum'});
 142
 143   } elsif ( $opt->{'cust_location'} ) {
 144
 145     my $error = $opt->{'cust_location'}->find_or_insert;
 146     if ( $error ) {
 147       $dbh->rollback if $oldAutoCommit;
 148       return "inserting cust_location (transaction rolled back): $error";
 149     }
 150     $cust_pkg->locationnum($opt->{'cust_location'}->locationnum);
 151
 152   } elsif ( ! $cust_pkg->locationnum ) {
 153
 154     $cust_pkg->locationnum($self->ship_locationnum);
 155
 156   }
 157
 158   $cust_pkg->custnum( $self->custnum );
 159
 160   my $error = $cust_pkg->insert( %insert_params );
 161   if ( $error ) {
 162     $dbh->rollback if $oldAutoCommit;
 163     return "inserting cust_pkg (transaction rolled back): $error";
 164   }
 165
 166   foreach my $svc_something ( @{ $opt->{'svcs'} } ) {
 167     if ( $svc_something->svcnum ) {
 168       my $old_cust_svc = $svc_something->cust_svc;
 169       my $new_cust_svc = new FS::cust_svc { $old_cust_svc->hash };
 170       $new_cust_svc->pkgnum( $cust_pkg->pkgnum);
 171       $error = $new_cust_svc->replace($old_cust_svc);
 172     } else {
 173       $svc_something->pkgnum( $cust_pkg->pkgnum );
 174       if ( $svc_something->isa('FS::svc_acct') ) {
 175         foreach ( grep { $opt->{$_.'_ref'} && ${ $opt->{$_.'_ref'} } }
 176                        qw( seconds upbytes downbytes totalbytes )      ) {
 177           $svc_something->$_( $svc_something->$_() + ${ $opt->{$_.'_ref'} } );
 178           ${ $opt->{$_.'_ref'} } = 0;
 179         }
 180       }
 181       $error = $svc_something->insert(%svc_options);
 182     }
 183     if ( $error ) {
 184       $dbh->rollback if $oldAutoCommit;
 185       return "inserting svc_ (transaction rolled back): $error";
 186     }
 187   }
 188
 189   # add supplemental packages, if any are needed
 190   my $part_pkg = FS::part_pkg->by_key($cust_pkg->pkgpart);
 191   foreach my $link ($part_pkg->supp_part_pkg_link) {
 192     #warn "inserting supplemental package ".$link->dst_pkgpart;
 193     my $pkg = FS::cust_pkg->new({
 194         'pkgpart'       => $link->dst_pkgpart,
 195         'pkglinknum'    => $link->pkglinknum,
 196         'custnum'       => $self->custnum,
 197         'main_pkgnum'   => $cust_pkg->pkgnum,
 198         # try to prevent as many surprises as possible
 199         'allow_pkgpart' => $opt->{'allow_pkgpart'},
 200         map { $_ => $cust_pkg->$_() }
 201           qw( pkgbatch
 202               start_date order_date expire adjourn contract_end
 203               refnum discountnum waive_setup
 204             )
 205     });
 206     $error = $self->order_pkg('cust_pkg'    => $pkg,
 207                               'locationnum' => $cust_pkg->locationnum);
 208     if ( $error ) {
 209       $dbh->rollback if $oldAutoCommit;
 210       return "inserting supplemental package: $error";
 211     }
 212   }
 213
 214   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 215   ''; #no error
 216
 217 }
 218
 219 =item order_pkgs HASHREF [ , OPTION => VALUE ... ]
 220
 221 Like the insert method on an existing record, this method orders multiple
 222 packages and included services atomicaly.  Pass a Tie::RefHash data structure
 223 to this method containing FS::cust_pkg and FS::svc_I<tablename> objects.
 224 There should be a better explanation of this, but until then, here's an
 225 example:
 226
 227   use Tie::RefHash;
 228   tie %hash, 'Tie::RefHash'; #this part is important
 229   %hash = (
 230     $cust_pkg => [ $svc_acct ],
 231     ...
 232   );
 233   $cust_main->order_pkgs( \%hash, 'noexport'=>1 );
 234
 235 Services can be new, in which case they are inserted, or existing unaudited
 236 services, in which case they are linked to the newly-created package.
 237
 238 Currently available options are: I<depend_jobnum>, I<noexport>, I<seconds_ref>,
 239 I<upbytes_ref>, I<downbytes_ref>, and I<totalbytes_ref>.
 240
 241 If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
 242 on the supplied jobnum (they will not run until the specific job completes).
 243 This can be used to defer provisioning until some action completes (such
 244 as running the customer's credit card successfully).
 245
 246 The I<noexport> option is deprecated but still works for now (use
 247 I<depend_jobnum> instead for new code).  If I<noexport> is set true, no
 248 provisioning jobs (exports) are scheduled.  (You can schedule them later with
 249 the B<reexport> method for each cust_pkg object.  Using the B<reexport> method
 250 on the cust_main object is not recommended, as existing services will also be
 251 reexported.)
 252
 253 If I<seconds_ref>, I<upbytes_ref>, I<downbytes_ref>, or I<totalbytes_ref> is
 254 provided, the scalars (provided by references) will be incremented by the
 255 values of the prepaid card.`
 256
 257 =cut
 258
 259 sub order_pkgs {
 260   my $self = shift;
 261   my $cust_pkgs = shift;
 262   my %options = @_;
 263
 264   local($DEBUG) = $FS::cust_main::DEBUG if $FS::cust_main::DEBUG > $DEBUG;
 265
 266   warn "$me order_pkgs called with options ".
 267        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 268     if $DEBUG;
 269
 270   local $SIG{HUP} = 'IGNORE';
 271   local $SIG{INT} = 'IGNORE';
 272   local $SIG{QUIT} = 'IGNORE';
 273   local $SIG{TERM} = 'IGNORE';
 274   local $SIG{TSTP} = 'IGNORE';
 275   local $SIG{PIPE} = 'IGNORE';
 276
 277   my $oldAutoCommit = $FS::UID::AutoCommit;
 278   local $FS::UID::AutoCommit = 0;
 279   my $dbh = dbh;
 280
 281   local $FS::svc_Common::noexport_hack = 1 if $options{'noexport'};
 282
 283   foreach my $cust_pkg ( keys %$cust_pkgs ) {
 284
 285     my $error = $self->order_pkg(
 286       'cust_pkg'     => $cust_pkg,
 287       'svcs'         => $cust_pkgs->{$cust_pkg},
 288       map { $_ => $options{$_} }
 289         qw( seconds_ref upbytes_ref downbytes_ref totalbytes_ref depend_jobnum )
 290     );
 291     if ( $error ) {
 292       $dbh->rollback if $oldAutoCommit;
 293       return $error;
 294     }
 295
 296   }
 297
 298   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 299   ''; #no error
 300 }
 301
 302 =item attach_pkgs
 303
 304 Merges this customer's package's into the target customer and then cancels them.
 305
 306 =cut
 307
 308 sub attach_pkgs {
 309   my( $self, $new_custnum ) = @_;
 310
 311   #mostly false laziness w/ merge
 312
 313   return "Can't attach packages to self" if $self->custnum == $new_custnum;
 314
 315   my $new_cust_main = qsearchs( 'cust_main', { 'custnum' => $new_custnum } )
 316     or return "Invalid new customer number: $new_custnum";
 317
 318   return 'Access denied: "Merge customer across agents" access right required to merge into a customer of a different agent'
 319     if $self->agentnum != $new_cust_main->agentnum
 320     && ! $FS::CurrentUser::CurrentUser->access_right('Merge customer across agents');
 321
 322   local $SIG{HUP} = 'IGNORE';
 323   local $SIG{INT} = 'IGNORE';
 324   local $SIG{QUIT} = 'IGNORE';
 325   local $SIG{TERM} = 'IGNORE';
 326   local $SIG{TSTP} = 'IGNORE';
 327   local $SIG{PIPE} = 'IGNORE';
 328
 329   my $oldAutoCommit = $FS::UID::AutoCommit;
 330   local $FS::UID::AutoCommit = 0;
 331   my $dbh = dbh;
 332
 333   if ( qsearch('agent', { 'agent_custnum' => $self->custnum } ) ) {
 334      $dbh->rollback if $oldAutoCommit;
 335      return "Can't merge a master agent customer";
 336   }
 337
 338   #use FS::access_user
 339   if ( qsearch('access_user', { 'user_custnum' => $self->custnum } ) ) {
 340      $dbh->rollback if $oldAutoCommit;
 341      return "Can't merge a master employee customer";
 342   }
 343
 344   if ( qsearch('cust_pay_pending', { 'custnum' => $self->custnum,
 345                                      'status'  => { op=>'!=', value=>'done' },
 346                                    }
 347               )
 348   ) {
 349      $dbh->rollback if $oldAutoCommit;
 350      return "Can't merge a customer with pending payments";
 351   }
 352
 353   #end of false laziness
 354
 355   #pull in contact
 356
 357   my %contact_hash = ( 'first'    => $self->first,
 358                        'last'     => $self->get('last'),
 359                        'custnum'  => $new_custnum,
 360                        'disabled' => '',
 361                      );
 362
 363   my $contact = qsearchs(  'contact', \%contact_hash)
 364                  || new FS::contact   \%contact_hash;
 365   unless ( $contact->contactnum ) {
 366     my $error = $contact->insert;
 367     if ( $error ) {
 368       $dbh->rollback if $oldAutoCommit;
 369       return $error;
 370     }
 371   }
 372
 373   foreach my $cust_pkg ( $self->ncancelled_pkgs ) {
 374
 375     my $cust_location = $cust_pkg->cust_location || $self->ship_location;
 376     my %loc_hash = $cust_location->hash;
 377     $loc_hash{'locationnum'} = '';
 378     $loc_hash{'custnum'}     = $new_custnum;
 379     $loc_hash{'disabled'}    = '';
 380     my $new_cust_location = qsearchs(  'cust_location', \%loc_hash)
 381                              || new FS::cust_location   \%loc_hash;
 382
 383     my $pkg_or_error = $cust_pkg->change( {
 384       'keep_dates'    => 1,
 385       'cust_main'     => $new_cust_main,
 386       'contactnum'    => $contact->contactnum,
 387       'cust_location' => $new_cust_location,
 388     } );
 389
 390     my $error = ref($pkg_or_error) ? '' : $pkg_or_error;
 391
 392     if ( $error ) {
 393       $dbh->rollback if $oldAutoCommit;
 394       return $error;
 395     }
 396
 397   }
 398
 399   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 400   ''; #no error
 401
 402 }
 403
 404 =item all_pkgs [ OPTION => VALUE... | EXTRA_QSEARCH_PARAMS_HASHREF ]
 405
 406 Returns all packages (see L<FS::cust_pkg>) for this customer.
 407
 408 =cut
 409
 410 sub all_pkgs {
 411   my $self = shift;
 412   my $extra_qsearch = ref($_[0]) ? shift : { @_ };
 413
 414   return $self->num_pkgs unless wantarray || keys %$extra_qsearch;
 415
 416   my @cust_pkg = ();
 417   if ( $self->{'_pkgnum'} && ! keys %$extra_qsearch ) {
 418     @cust_pkg = values %{ $self->{'_pkgnum'}->cache };
 419   } else {
 420     @cust_pkg = $self->_cust_pkg($extra_qsearch);
 421   }
 422
 423   local($skip_label_sort) = 1 if $extra_qsearch->{skip_label_sort};
 424   map { $_ } sort sort_packages @cust_pkg;
 425
 426 }
 427
 428 =item cust_pkg
 429
 430 Synonym for B<all_pkgs>.
 431
 432 =cut
 433
 434 sub cust_pkg {
 435   shift->all_pkgs(@_);
 436 }
 437
 438 =item ncancelled_pkgs [ EXTRA_QSEARCH_PARAMS_HASHREF ]
 439
 440 Returns all non-cancelled packages (see L<FS::cust_pkg>) for this customer.
 441
 442 =cut
 443
 444 sub ncancelled_pkgs {
 445   my $self = shift;
 446   my $extra_qsearch = ref($_[0]) ? shift : {};
 447
 448   local($DEBUG) = $FS::cust_main::DEBUG if $FS::cust_main::DEBUG > $DEBUG;
 449
 450   return $self->num_ncancelled_pkgs unless wantarray;
 451
 452   my @cust_pkg = ();
 453   if ( $self->{'_pkgnum'} ) {
 454
 455     warn "$me ncancelled_pkgs: returning cached objects"
 456       if $DEBUG > 1;
 457
 458     @cust_pkg = grep { ! $_->getfield('cancel') }
 459                 values %{ $self->{'_pkgnum'}->cache };
 460
 461   } else {
 462
 463     warn "$me ncancelled_pkgs: searching for packages with custnum ".
 464          $self->custnum. "\n"
 465       if $DEBUG > 1;
 466
 467     $extra_qsearch->{'extra_sql'} .= ' AND ( cancel IS NULL OR cancel = 0 ) ';
 468
 469     @cust_pkg = $self->_cust_pkg($extra_qsearch);
 470
 471   }
 472
 473   local($skip_label_sort) = 1 if $extra_qsearch->{skip_label_sort};
 474   sort sort_packages @cust_pkg;
 475
 476 }
 477
 478 =item cancelled_pkgs [ EXTRA_QSEARCH_PARAMS_HASHREF ]
 479
 480 Returns all cancelled packages (see L<FS::cust_pkg>) for this customer.
 481
 482 =cut
 483
 484 sub cancelled_pkgs {
 485   my $self = shift;
 486   my $extra_qsearch = ref($_[0]) ? shift : { @_ };
 487
 488   return $self->num_cancelled_pkgs($extra_qsearch) unless wantarray;
 489
 490   $extra_qsearch->{'extra_sql'} .=
 491     ' AND cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel > 0 ';
 492
 493   local($skip_label_sort) = 1 if $extra_qsearch->{skip_label_sort};
 494
 495   sort sort_packages $self->_cust_pkg($extra_qsearch);
 496 }
 497
 498 sub _cust_pkg {
 499   my $self = shift;
 500   my $extra_qsearch = ref($_[0]) ? shift : {};
 501
 502   $extra_qsearch->{'select'} ||= '*';
 503   $extra_qsearch->{'select'} .=
 504    ',( SELECT COUNT(*) FROM cust_svc WHERE cust_pkg.pkgnum = cust_svc.pkgnum )
 505      AS _num_cust_svc';
 506
 507   map {
 508         $_->{'_num_cust_svc'} = $_->get('_num_cust_svc');
 509         $_;
 510       }
 511   qsearch({
 512     %$extra_qsearch,
 513     'table'   => 'cust_pkg',
 514     'hashref' => { 'custnum' => $self->custnum },
 515   });
 516
 517 }
 518
 519 # This should be generalized to use config options to determine order.
 520 sub sort_packages {
 521
 522   my $locationsort = ( $a->locationnum || 0 ) <=> ( $b->locationnum || 0 );
 523   return $locationsort if $locationsort;
 524
 525   if ( $a->get('cancel') xor $b->get('cancel') ) {
 526     return -1 if $b->get('cancel');
 527     return  1 if $a->get('cancel');
 528     #shouldn't get here...
 529     return 0;
 530   } else {
 531     my $a_num_cust_svc = $a->num_cust_svc;
 532     my $b_num_cust_svc = $b->num_cust_svc;
 533     return 0  if !$a_num_cust_svc && !$b_num_cust_svc;
 534     return -1 if  $a_num_cust_svc && !$b_num_cust_svc;
 535     return 1  if !$a_num_cust_svc &&  $b_num_cust_svc;
 536     return 0 if $skip_label_sort
 537              || $a_num_cust_svc + $b_num_cust_svc > 20; #for perf, just give up
 538     my @a_cust_svc = $a->cust_svc_unsorted;
 539     my @b_cust_svc = $b->cust_svc_unsorted;
 540     return 0  if !scalar(@a_cust_svc) && !scalar(@b_cust_svc);
 541     return -1 if  scalar(@a_cust_svc) && !scalar(@b_cust_svc);
 542     return 1  if !scalar(@a_cust_svc) &&  scalar(@b_cust_svc);
 543     $a_cust_svc[0]->svc_x->label cmp $b_cust_svc[0]->svc_x->label;
 544   }
 545
 546 }
 547
 548 =item suspended_pkgs
 549
 550 Returns all suspended packages (see L<FS::cust_pkg>) for this customer.
 551
 552 =cut
 553
 554 sub suspended_pkgs {
 555   my $self = shift;
 556   return $self->num_suspended_pkgs unless wantarray;
 557   grep { $_->susp } $self->ncancelled_pkgs;
 558 }
 559
 560 ### This appears to be unused, will be going away
 561 #
 562 #=item unflagged_suspended_pkgs
 563 #
 564 #Returns all unflagged suspended packages (see L<FS::cust_pkg>) for this
 565 #customer (thouse packages without the `manual_flag' set).
 566 #
 567 #=cut
 568
 569 sub unflagged_suspended_pkgs {
 570   my $self = shift;
 571   return $self->suspended_pkgs
 572     unless dbdef->table('cust_pkg')->column('manual_flag');
 573   grep { ! $_->manual_flag } $self->suspended_pkgs;
 574 }
 575
 576 =item unsuspended_pkgs
 577
 578 Returns all unsuspended (and uncancelled) packages (see L<FS::cust_pkg>) for
 579 this customer.
 580
 581 =cut
 582
 583 sub unsuspended_pkgs {
 584   my $self = shift;
 585   return $self->num_unsuspended_pkgs unless wantarray;
 586   grep { ! $_->susp } $self->ncancelled_pkgs;
 587 }
 588
 589 =item active_pkgs
 590
 591 Returns all unsuspended (and uncancelled) packages (see L<FS::cust_pkg>) for
 592 this customer that are active (recurring).
 593
 594 =cut
 595
 596 sub active_pkgs {
 597   my $self = shift;
 598   grep { my $part_pkg = $_->part_pkg;
 599          $part_pkg->freq ne '' && $part_pkg->freq ne '0';
 600        }
 601        $self->unsuspended_pkgs;
 602 }
 603
 604 =item ncancelled_active_pkgs
 605
 606 Returns all non-cancelled packages (see L<FS::cust_pkg>) for this customer that
 607 are active (recurring).
 608
 609 =cut
 610
 611 sub ncancelled_active_pkgs {
 612   my $self = shift;
 613   grep { my $part_pkg = $_->part_pkg;
 614          $part_pkg->freq ne '' && $part_pkg->freq ne '0';
 615        }
 616        $self->ncancelled_pkgs;
 617 }
 618
 619 =item billing_pkgs
 620
 621 Returns active packages, and also any suspended packages which are set to
 622 continue billing while suspended.
 623
 624 =cut
 625
 626 sub billing_pkgs {
 627   my $self = shift;
 628   grep { my $part_pkg = $_->part_pkg;
 629          $part_pkg->freq ne '' && $part_pkg->freq ne '0'
 630            && ( ! $_->susp || $_->option('suspend_bill',1)
 631                            || ( $part_pkg->option('suspend_bill', 1)
 632                                   && ! $_->option('no_suspend_bill',1)
 633                               )
 634               );
 635        }
 636        $self->ncancelled_pkgs;
 637 }
 638
 639 =item next_bill_date
 640
 641 Returns the next date this customer will be billed, as a UNIX timestamp, or
 642 undef if no billing package has a next bill date.
 643
 644 =cut
 645
 646 sub next_bill_date {
 647   my $self = shift;
 648   min( map $_->get('bill'), grep $_->get('bill'), $self->billing_pkgs );
 649 }
 650
 651 =item num_cancelled_pkgs
 652
 653 Returns the number of cancelled packages (see L<FS::cust_pkg>) for this
 654 customer.
 655
 656 =cut
 657
 658 sub num_cancelled_pkgs {
 659   shift->num_pkgs("cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0");
 660 }
 661
 662 =item num_ncancelled_pkgs
 663
 664 Returns the number of packages that have not been cancelled (see L<FS::cust_pkg>) for this
 665 customer.
 666
 667 =cut
 668
 669 sub num_ncancelled_pkgs {
 670   shift->num_pkgs("( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )");
 671 }
 672
 673 =item num_billing_pkgs
 674
 675 Returns the number of packages that have not been cancelled
 676 and have a non-zero billing frequency (see L<FS::cust_pkg>)
 677 for this customer.
 678
 679 =cut
 680
 681 sub num_billing_pkgs {
 682   my $self = shift;
 683   my $opt = shift || {};
 684   $opt->{addl_from} .= ' LEFT JOIN part_pkg USING (pkgpart)';
 685   $opt->{extra_sql} .= ' AND ' if $opt->{extra_sql};
 686   $opt->{extra_sql} .= "freq IS NOT NULL AND freq != '0'";
 687   $self->num_ncancelled_pkgs($opt);
 688 }
 689
 690 sub num_suspended_pkgs {
 691   shift->num_pkgs("     ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
 692                     AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0   ");
 693 }
 694
 695 sub num_unsuspended_pkgs {
 696   shift->num_pkgs("     ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
 697                     AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 ) ");
 698 }
 699
 700 sub num_pkgs {
 701   my( $self ) = shift;
 702   my $sql = scalar(@_) ? shift : '';
 703   $sql = "AND $sql" if $sql && $sql !~ /^\s*$/ && $sql !~ /^\s*AND/i;
 704   my $sth = dbh->prepare(
 705     "SELECT COUNT(*) FROM cust_pkg WHERE custnum = ? $sql"
 706   ) or die dbh->errstr;
 707   $sth->execute($self->custnum) or die $sth->errstr;
 708   $sth->fetchrow_arrayref->[0];
 709 }
 710
 711 =item num_usage_pkgs
 712
 713 Returns the number of packages for this customer that have services that
 714 can have RADIUS usage statistics.
 715
 716 =cut
 717
 718 sub num_usage_pkgs {
 719   my $self = shift;
 720   # have to enumerate exportnums but it's not bad
 721   my @exportnums = map { $_->exportnum }
 722                    grep { $_->can('usage_sessions') }
 723                    qsearch('part_export');
 724   return 0 if !@exportnums;
 725   my $in_exportnums = join(',', @exportnums);
 726   my $sql = "SELECT COUNT(DISTINCT pkgnum) FROM cust_pkg
 727     JOIN cust_svc USING (pkgnum)
 728     JOIN export_svc USING (svcpart)
 729     WHERE exportnum IN( $in_exportnums ) AND custnum = ?";
 730   FS::Record->scalar_sql($sql, $self->custnum);
 731 }
 732
 733 =item display_recurring
 734
 735 Returns an array of hash references, one for each recurring freq
 736 on billable customer packages, with keys of freq, freq_pretty and amount
 737 (the amount that this customer will next be charged at the given frequency.)
 738
 739 Results will be numerically sorted by freq.
 740
 741 Only intended for display purposes, not used for actual billing.
 742
 743 =cut
 744
 745 sub display_recurring {
 746   my $cust_main = shift;
 747
 748   my $sth = dbh->prepare("
 749     SELECT DISTINCT freq FROM cust_pkg LEFT JOIN part_pkg USING (pkgpart)
 750       WHERE freq IS NOT NULL AND freq != '0'
 751         AND ( cancel IS NULL OR cancel = 0 )
 752         AND custnum = ?
 753   ") or die $DBI::errstr;
 754
 755   $sth->execute($cust_main->custnum) or die $sth->errstr;
 756
 757   #not really a numeric sort because freqs can actually be all sorts of things
 758   # but good enough for the 99% cases of ordering monthly quarterly annually
 759   my @freqs = sort { $a <=> $b } map { $_->[0] } @{ $sth->fetchall_arrayref };
 760
 761   $sth->finish;
 762
 763   my @out;
 764
 765   foreach my $freq (@freqs) {
 766
 767     my @cust_pkg = qsearch({
 768       'table'     => 'cust_pkg',
 769       'addl_from' => 'LEFT JOIN part_pkg USING (pkgpart)',
 770       'hashref'   => { 'custnum' => $cust_main->custnum, },
 771       'extra_sql' => 'AND ( cancel IS NULL OR cancel = 0 )
 772                       AND freq = '. dbh->quote($freq),
 773       'order_by'  => 'ORDER BY COALESCE(start_date,0), pkgnum', # to ensure old pkgs come before change_to_pkg
 774     }) or next;
 775
 776     my $freq_pretty = $cust_pkg[0]->part_pkg->freq_pretty;
 777
 778     my $amount = 0;
 779     my $skip_pkg = {};
 780     foreach my $cust_pkg (@cust_pkg) {
 781       my $part_pkg = $cust_pkg->part_pkg;
 782       next if $cust_pkg->susp
 783            && ! $cust_pkg->option('suspend_bill')
 784            && ( ! $part_pkg->option('suspend_bill')
 785                 || $cust_pkg->option('no_suspend_bill')
 786               );
 787
 788       #pkg change handling
 789       next if $skip_pkg->{$cust_pkg->pkgnum};
 790       if ($cust_pkg->change_to_pkgnum) {
 791         #if change is on or before next bill date, use new pkg
 792         next if $cust_pkg->expire <= $cust_pkg->bill;
 793         #if change is after next bill date, use old (this) pkg
 794         $skip_pkg->{$cust_pkg->change_to_pkgnum} = 1;
 795       }
 796
 797       my $pkg_amount = 0;
 798
 799       #add recurring amounts for this package and its billing add-ons
 800       foreach my $l_part_pkg ( $part_pkg->self_and_bill_linked ) {
 801         $pkg_amount += $l_part_pkg->base_recur($cust_pkg);
 802       }
 803
 804       #subtract amounts for any active discounts
 805       #(there should only be one at the moment, otherwise this makes no sense)
 806       foreach my $cust_pkg_discount ( $cust_pkg->cust_pkg_discount_active ) {
 807         my $discount = $cust_pkg_discount->discount;
 808         #and only one of these for each
 809         $pkg_amount -= $discount->amount;
 810         $pkg_amount -= $amount * $discount->percent/100;
 811       }
 812
 813       $pkg_amount *= ( $cust_pkg->quantity || 1 );
 814
 815       $amount += $pkg_amount;
 816
 817     } #foreach $cust_pkg
 818
 819     next unless $amount;
 820     push @out, {
 821       'freq'        => $freq,
 822       'freq_pretty' => $freq_pretty,
 823       'amount'      => $amount,
 824     };
 825
 826   } #foreach $freq
 827
 828   return @out;
 829 }
 830
 831 =back
 832
 833 =head1 BUGS
 834
 835 =head1 SEE ALSO
 836
 837 L<FS::cust_main>, L<FS::cust_pkg>
 838
 839 =cut
 840
 841 1;
 842