FS/FS/cust_svc.pm

   1 package FS::cust_svc;
   2
   3 use strict;
   4 use vars qw( @ISA $DEBUG $me $ignore_quantity );
   5 use Carp;
   6 use FS::Conf;
   7 use FS::Record qw( qsearch qsearchs dbh str2time_sql );
   8 use FS::cust_pkg;
   9 use FS::part_pkg;
  10 use FS::part_svc;
  11 use FS::pkg_svc;
  12 use FS::domain_record;
  13 use FS::part_export;
  14 use FS::cdr;
  15
  16 #most FS::svc_ classes are autoloaded in svc_x emthod
  17 use FS::svc_acct;  #this one is used in the cache stuff
  18
  19 @ISA = qw( FS::cust_main_Mixin FS::Record );
  20
  21 $DEBUG = 0;
  22 $me = '[cust_svc]';
  23
  24 $ignore_quantity = 0;
  25
  26 sub _cache {
  27   my $self = shift;
  28   my ( $hashref, $cache ) = @_;
  29   if ( $hashref->{'username'} ) {
  30     $self->{'_svc_acct'} = FS::svc_acct->new($hashref, '');
  31   }
  32   if ( $hashref->{'svc'} ) {
  33     $self->{'_svcpart'} = FS::part_svc->new($hashref);
  34   }
  35 }
  36
  37 =head1 NAME
  38
  39 FS::cust_svc - Object method for cust_svc objects
  40
  41 =head1 SYNOPSIS
  42
  43   use FS::cust_svc;
  44
  45   $record = new FS::cust_svc \%hash
  46   $record = new FS::cust_svc { 'column' => 'value' };
  47
  48   $error = $record->insert;
  49
  50   $error = $new_record->replace($old_record);
  51
  52   $error = $record->delete;
  53
  54   $error = $record->check;
  55
  56   ($label, $value) = $record->label;
  57
  58 =head1 DESCRIPTION
  59
  60 An FS::cust_svc represents a service.  FS::cust_svc inherits from FS::Record.
  61 The following fields are currently supported:
  62
  63 =over 4
  64
  65 =item svcnum - primary key (assigned automatically for new services)
  66
  67 =item pkgnum - Package (see L<FS::cust_pkg>)
  68
  69 =item svcpart - Service definition (see L<FS::part_svc>)
  70
  71 =item overlimit - date the service exceeded its usage limit
  72
  73 =back
  74
  75 =head1 METHODS
  76
  77 =over 4
  78
  79 =item new HASHREF
  80
  81 Creates a new service.  To add the refund to the database, see L<"insert">.
  82 Services are normally created by creating FS::svc_ objects (see
  83 L<FS::svc_acct>, L<FS::svc_domain>, and L<FS::svc_forward>, among others).
  84
  85 =cut
  86
  87 sub table { 'cust_svc'; }
  88
  89 =item insert
  90
  91 Adds this service to the database.  If there is an error, returns the error,
  92 otherwise returns false.
  93
  94 =item delete
  95
  96 Deletes this service from the database.  If there is an error, returns the
  97 error, otherwise returns false.  Note that this only removes the cust_svc
  98 record - you should probably use the B<cancel> method instead.
  99
 100 =item cancel
 101
 102 Cancels the relevant service by calling the B<cancel> method of the associated
 103 FS::svc_XXX object (i.e. an FS::svc_acct object or FS::svc_domain object),
 104 deleting the FS::svc_XXX record and then deleting this record.
 105
 106 If there is an error, returns the error, otherwise returns false.
 107
 108 =cut
 109
 110 sub cancel {
 111   my $self = shift;
 112
 113   local $SIG{HUP} = 'IGNORE';
 114   local $SIG{INT} = 'IGNORE';
 115   local $SIG{QUIT} = 'IGNORE';
 116   local $SIG{TERM} = 'IGNORE';
 117   local $SIG{TSTP} = 'IGNORE';
 118   local $SIG{PIPE} = 'IGNORE';
 119
 120   my $oldAutoCommit = $FS::UID::AutoCommit;
 121   local $FS::UID::AutoCommit = 0;
 122   my $dbh = dbh;
 123
 124   my $part_svc = $self->part_svc;
 125
 126   $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 127     $dbh->rollback if $oldAutoCommit;
 128     return "Illegal svcdb value in part_svc!";
 129   };
 130   my $svcdb = $1;
 131   require "FS/$svcdb.pm";
 132
 133   my $svc = $self->svc_x;
 134   if ($svc) {
 135
 136     my $error = $svc->cancel;
 137     if ( $error ) {
 138       $dbh->rollback if $oldAutoCommit;
 139       return "Error canceling service: $error";
 140     }
 141     $error = $svc->delete; #this deletes this cust_svc record as well
 142     if ( $error ) {
 143       $dbh->rollback if $oldAutoCommit;
 144       return "Error deleting service: $error";
 145     }
 146
 147   } else {
 148
 149     #huh?
 150     warn "WARNING: no svc_ record found for svcnum ". $self->svcnum.
 151          "; deleting cust_svc only\n";
 152
 153     my $error = $self->delete;
 154     if ( $error ) {
 155       $dbh->rollback if $oldAutoCommit;
 156       return "Error deleting cust_svc: $error";
 157     }
 158
 159   }
 160
 161   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 162
 163   ''; #no errors
 164
 165 }
 166
 167 =item overlimit [ ACTION ]
 168
 169 Retrieves or sets the overlimit date.  If ACTION is absent, return
 170 the present value of overlimit.  If ACTION is present, it can
 171 have the value 'suspend' or 'unsuspend'.  In the case of 'suspend' overlimit
 172 is set to the current time if it is not already set.  The 'unsuspend' value
 173 causes the time to be cleared.
 174
 175 If there is an error on setting, returns the error, otherwise returns false.
 176
 177 =cut
 178
 179 sub overlimit {
 180   my $self = shift;
 181   my $action = shift or return $self->getfield('overlimit');
 182
 183   local $SIG{HUP} = 'IGNORE';
 184   local $SIG{INT} = 'IGNORE';
 185   local $SIG{QUIT} = 'IGNORE';
 186   local $SIG{TERM} = 'IGNORE';
 187   local $SIG{TSTP} = 'IGNORE';
 188   local $SIG{PIPE} = 'IGNORE';
 189
 190   my $oldAutoCommit = $FS::UID::AutoCommit;
 191   local $FS::UID::AutoCommit = 0;
 192   my $dbh = dbh;
 193
 194   if ( $action eq 'suspend' ) {
 195     $self->setfield('overlimit', time) unless $self->getfield('overlimit');
 196   }elsif ( $action eq 'unsuspend' ) {
 197     $self->setfield('overlimit', '');
 198   }else{
 199     die "unexpected action value: $action";
 200   }
 201
 202   local $ignore_quantity = 1;
 203   my $error = $self->replace;
 204   if ( $error ) {
 205     $dbh->rollback if $oldAutoCommit;
 206     return "Error setting overlimit: $error";
 207   }
 208
 209   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 210
 211   ''; #no errors
 212
 213 }
 214
 215 =item replace OLD_RECORD
 216
 217 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 218 returns the error, otherwise returns false.
 219
 220 =cut
 221
 222 sub replace {
 223   my ( $new, $old ) = ( shift, shift );
 224
 225   local $SIG{HUP} = 'IGNORE';
 226   local $SIG{INT} = 'IGNORE';
 227   local $SIG{QUIT} = 'IGNORE';
 228   local $SIG{TERM} = 'IGNORE';
 229   local $SIG{TSTP} = 'IGNORE';
 230   local $SIG{PIPE} = 'IGNORE';
 231
 232   my $oldAutoCommit = $FS::UID::AutoCommit;
 233   local $FS::UID::AutoCommit = 0;
 234   my $dbh = dbh;
 235
 236   $old = $new->replace_old unless defined($old);
 237
 238   if ( $new->svcpart != $old->svcpart ) {
 239     my $svc_x = $new->svc_x;
 240     my $new_svc_x = ref($svc_x)->new({$svc_x->hash, svcpart=>$new->svcpart });
 241     local($FS::Record::nowarn_identical) = 1;
 242     my $error = $new_svc_x->replace($svc_x);
 243     if ( $error ) {
 244       $dbh->rollback if $oldAutoCommit;
 245       return $error if $error;
 246     }
 247   }
 248
 249   my $error = $new->SUPER::replace($old);
 250   if ( $error ) {
 251     $dbh->rollback if $oldAutoCommit;
 252     return $error if $error;
 253   }
 254
 255   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 256   ''; #no error
 257
 258 }
 259
 260 =item check
 261
 262 Checks all fields to make sure this is a valid service.  If there is an error,
 263 returns the error, otherwise returns false.  Called by the insert and
 264 replace methods.
 265
 266 =cut
 267
 268 sub check {
 269   my $self = shift;
 270
 271   my $error =
 272     $self->ut_numbern('svcnum')
 273     || $self->ut_numbern('pkgnum')
 274     || $self->ut_number('svcpart')
 275     || $self->ut_numbern('overlimit')
 276   ;
 277   return $error if $error;
 278
 279   my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } );
 280   return "Unknown svcpart" unless $part_svc;
 281
 282   if ( $self->pkgnum ) {
 283     my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
 284     return "Unknown pkgnum" unless $cust_pkg;
 285     my $pkg_svc = qsearchs( 'pkg_svc', {
 286       'pkgpart' => $cust_pkg->pkgpart,
 287       'svcpart' => $self->svcpart,
 288     });
 289     # or new FS::pkg_svc ( { 'pkgpart'  => $cust_pkg->pkgpart,
 290     #                        'svcpart'  => $self->svcpart,
 291     #                        'quantity' => 0                   } );
 292     my $quantity = $pkg_svc ? $pkg_svc->quantity : 0;
 293
 294     my @cust_svc = qsearch('cust_svc', {
 295       'pkgnum'  => $self->pkgnum,
 296       'svcpart' => $self->svcpart,
 297     });
 298     return "Already ". scalar(@cust_svc). " ". $part_svc->svc.
 299            " services for pkgnum ". $self->pkgnum
 300       if scalar(@cust_svc) >= $quantity && !$ignore_quantity;
 301   }
 302
 303   $self->SUPER::check;
 304 }
 305
 306 =item part_svc
 307
 308 Returns the definition for this service, as a FS::part_svc object (see
 309 L<FS::part_svc>).
 310
 311 =cut
 312
 313 sub part_svc {
 314   my $self = shift;
 315   $self->{'_svcpart'}
 316     ? $self->{'_svcpart'}
 317     : qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } );
 318 }
 319
 320 =item cust_pkg
 321
 322 Returns the package this service belongs to, as a FS::cust_pkg object (see
 323 L<FS::cust_pkg>).
 324
 325 =cut
 326
 327 sub cust_pkg {
 328   my $self = shift;
 329   qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
 330 }
 331
 332 =item pkg_svc
 333
 334 Returns the pkg_svc record for for this service, if applicable.
 335
 336 =cut
 337
 338 sub pkg_svc {
 339   my $self = shift;
 340   my $cust_pkg = $self->cust_pkg;
 341   return undef unless $cust_pkg;
 342
 343   qsearchs( 'pkg_svc', { 'svcpart' => $self->svcpart,
 344                          'pkgpart' => $cust_pkg->pkgpart,
 345                        }
 346           );
 347 }
 348
 349 =item date_inserted
 350
 351 Returns the date this service was inserted.
 352
 353 =cut
 354
 355 sub date_inserted {
 356   my $self = shift;
 357   $self->h_date('insert');
 358 }
 359
 360 =item label
 361
 362 Returns a list consisting of:
 363 - The name of this service (from part_svc)
 364 - A meaningful identifier (username, domain, or mail alias)
 365 - The table name (i.e. svc_domain) for this service
 366 - svcnum
 367
 368 Usage example:
 369
 370   my($label, $value, $svcdb) = $cust_svc->label;
 371
 372 =cut
 373
 374 sub label {
 375   my $self = shift;
 376   carp "FS::cust_svc::label called on $self" if $DEBUG;
 377   my $svc_x = $self->svc_x
 378     or return "can't find ". $self->part_svc->svcdb. '.svcnum '. $self->svcnum;
 379
 380   $self->_svc_label($svc_x);
 381 }
 382
 383 sub _svc_label {
 384   my( $self, $svc_x ) = ( shift, shift );
 385
 386   (
 387     $self->part_svc->svc,
 388     $svc_x->label(@_),
 389     $self->part_svc->svcdb,
 390     $self->svcnum
 391   );
 392
 393 }
 394
 395 =item svc_x
 396
 397 Returns the FS::svc_XXX object for this service (i.e. an FS::svc_acct object or
 398 FS::svc_domain object, etc.)
 399
 400 =cut
 401
 402 sub svc_x {
 403   my $self = shift;
 404   my $svcdb = $self->part_svc->svcdb;
 405   if ( $svcdb eq 'svc_acct' && $self->{'_svc_acct'} ) {
 406     $self->{'_svc_acct'};
 407   } else {
 408     require "FS/$svcdb.pm";
 409     warn "$me svc_x: part_svc.svcpart ". $self->part_svc->svcpart.
 410          ", so searching for $svcdb.svcnum ". $self->svcnum. "\n"
 411       if $DEBUG;
 412     qsearchs( $svcdb, { 'svcnum' => $self->svcnum } );
 413   }
 414 }
 415
 416 =item seconds_since TIMESTAMP
 417
 418 See L<FS::svc_acct/seconds_since>.  Equivalent to
 419 $cust_svc->svc_x->seconds_since, but more efficient.  Meaningless for records
 420 where B<svcdb> is not "svc_acct".
 421
 422 =cut
 423
 424 #note: implementation here, POD in FS::svc_acct
 425 sub seconds_since {
 426   my($self, $since) = @_;
 427   my $dbh = dbh;
 428   my $sth = $dbh->prepare(' SELECT SUM(logout-login) FROM session
 429                               WHERE svcnum = ?
 430                                 AND login >= ?
 431                                 AND logout IS NOT NULL'
 432   ) or die $dbh->errstr;
 433   $sth->execute($self->svcnum, $since) or die $sth->errstr;
 434   $sth->fetchrow_arrayref->[0];
 435 }
 436
 437 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 438
 439 See L<FS::svc_acct/seconds_since_sqlradacct>.  Equivalent to
 440 $cust_svc->svc_x->seconds_since_sqlradacct, but more efficient.  Meaningless
 441 for records where B<svcdb> is not "svc_acct".
 442
 443 =cut
 444
 445 #note: implementation here, POD in FS::svc_acct
 446 sub seconds_since_sqlradacct {
 447   my($self, $start, $end) = @_;
 448
 449   my $svc_x = $self->svc_x;
 450
 451   my @part_export = $self->part_svc->part_export_usage;
 452   die "no accounting-capable exports are enabled for ". $self->part_svc->svc.
 453       " service definition"
 454     unless @part_export;
 455     #or return undef;
 456
 457   my $seconds = 0;
 458   foreach my $part_export ( @part_export ) {
 459
 460     next if $part_export->option('ignore_accounting');
 461
 462     my $dbh = DBI->connect( map { $part_export->option($_) }
 463                             qw(datasrc username password)    )
 464       or die "can't connect to sqlradius database: ". $DBI::errstr;
 465
 466     #select a unix time conversion function based on database type
 467     my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
 468
 469     my $username = $part_export->export_username($svc_x);
 470
 471     my $query;
 472
 473     #find closed sessions completely within the given range
 474     my $sth = $dbh->prepare("SELECT SUM(acctsessiontime)
 475                                FROM radacct
 476                                WHERE UserName = ?
 477                                  AND $str2time AcctStartTime) >= ?
 478                                  AND $str2time AcctStopTime ) <  ?
 479                                  AND $str2time AcctStopTime ) > 0
 480                                  AND AcctStopTime IS NOT NULL"
 481     ) or die $dbh->errstr;
 482     $sth->execute($username, $start, $end) or die $sth->errstr;
 483     my $regular = $sth->fetchrow_arrayref->[0];
 484
 485     #find open sessions which start in the range, count session start->range end
 486     $query = "SELECT SUM( ? - $str2time AcctStartTime ) )
 487                 FROM radacct
 488                 WHERE UserName = ?
 489                   AND $str2time AcctStartTime ) >= ?
 490                   AND $str2time AcctStartTime ) <  ?
 491                   AND ( ? - $str2time AcctStartTime ) ) < 86400
 492                   AND (    $str2time AcctStopTime ) = 0
 493                                     OR AcctStopTime IS NULL )";
 494     $sth = $dbh->prepare($query) or die $dbh->errstr;
 495     $sth->execute($end, $username, $start, $end, $end)
 496       or die $sth->errstr. " executing query $query";
 497     my $start_during = $sth->fetchrow_arrayref->[0];
 498
 499     #find closed sessions which start before the range but stop during,
 500     #count range start->session end
 501     $sth = $dbh->prepare("SELECT SUM( $str2time AcctStopTime ) - ? )
 502                             FROM radacct
 503                             WHERE UserName = ?
 504                               AND $str2time AcctStartTime ) < ?
 505                               AND $str2time AcctStopTime  ) >= ?
 506                               AND $str2time AcctStopTime  ) <  ?
 507                               AND $str2time AcctStopTime ) > 0
 508                               AND AcctStopTime IS NOT NULL"
 509     ) or die $dbh->errstr;
 510     $sth->execute($start, $username, $start, $start, $end ) or die $sth->errstr;
 511     my $end_during = $sth->fetchrow_arrayref->[0];
 512
 513     #find closed (not anymore - or open) sessions which start before the range
 514     # but stop after, or are still open, count range start->range end
 515     # don't count open sessions (probably missing stop record)
 516     $sth = $dbh->prepare("SELECT COUNT(*)
 517                             FROM radacct
 518                             WHERE UserName = ?
 519                               AND $str2time AcctStartTime ) < ?
 520                               AND ( $str2time AcctStopTime ) >= ?
 521                                                                   )"
 522                               #      OR AcctStopTime =  0
 523                               #      OR AcctStopTime IS NULL       )"
 524     ) or die $dbh->errstr;
 525     $sth->execute($username, $start, $end ) or die $sth->errstr;
 526     my $entire_range = ($end-$start) * $sth->fetchrow_arrayref->[0];
 527
 528     $seconds += $regular + $end_during + $start_during + $entire_range;
 529
 530   }
 531
 532   $seconds;
 533
 534 }
 535
 536 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 537
 538 See L<FS::svc_acct/attribute_since_sqlradacct>.  Equivalent to
 539 $cust_svc->svc_x->attribute_since_sqlradacct, but more efficient.  Meaningless
 540 for records where B<svcdb> is not "svc_acct".
 541
 542 =cut
 543
 544 #note: implementation here, POD in FS::svc_acct
 545 #(false laziness w/seconds_since_sqlradacct above)
 546 sub attribute_since_sqlradacct {
 547   my($self, $start, $end, $attrib) = @_;
 548
 549   my $svc_x = $self->svc_x;
 550
 551   my @part_export = $self->part_svc->part_export_usage;
 552   die "no accounting-capable exports are enabled for ". $self->part_svc->svc.
 553       " service definition"
 554     unless @part_export;
 555     #or return undef;
 556
 557   my $sum = 0;
 558
 559   foreach my $part_export ( @part_export ) {
 560
 561     next if $part_export->option('ignore_accounting');
 562
 563     my $dbh = DBI->connect( map { $part_export->option($_) }
 564                             qw(datasrc username password)    )
 565       or die "can't connect to sqlradius database: ". $DBI::errstr;
 566
 567     #select a unix time conversion function based on database type
 568     my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
 569
 570     my $username = $part_export->export_username($svc_x);
 571
 572     my $sth = $dbh->prepare("SELECT SUM($attrib)
 573                                FROM radacct
 574                                WHERE UserName = ?
 575                                  AND $str2time AcctStopTime ) >= ?
 576                                  AND $str2time AcctStopTime ) <  ?
 577                                  AND AcctStopTime IS NOT NULL"
 578     ) or die $dbh->errstr;
 579     $sth->execute($username, $start, $end) or die $sth->errstr;
 580
 581     $sum += $sth->fetchrow_arrayref->[0];
 582
 583   }
 584
 585   $sum;
 586
 587 }
 588
 589 =item get_session_history TIMESTAMP_START TIMESTAMP_END
 590
 591 See L<FS::svc_acct/get_session_history>.  Equivalent to
 592 $cust_svc->svc_x->get_session_history, but more efficient.  Meaningless for
 593 records where B<svcdb> is not "svc_acct".
 594
 595 =cut
 596
 597 sub get_session_history {
 598   my($self, $start, $end, $attrib) = @_;
 599
 600   #$attrib ???
 601
 602   my @part_export = $self->part_svc->part_export_usage;
 603   die "no accounting-capable exports are enabled for ". $self->part_svc->svc.
 604       " service definition"
 605     unless @part_export;
 606     #or return undef;
 607
 608   my @sessions = ();
 609
 610   foreach my $part_export ( @part_export ) {
 611     push @sessions,
 612       @{ $part_export->usage_sessions( $start, $end, $self->svc_x ) };
 613   }
 614
 615   @sessions;
 616
 617 }
 618
 619 =item get_cdrs_for_update
 620
 621 Returns (and SELECTs "FOR UPDATE") all unprocessed (freesidestatus NULL) CDR
 622 objects (see L<FS::cdr>) associated with this service.
 623
 624 CDRs are associated with svc_phone services via svc_phone.phonenum
 625
 626 =cut
 627
 628 sub get_cdrs_for_update {
 629   my($self, %options) = @_;
 630
 631   my $default_prefix = $options{'default_prefix'};
 632
 633   #CDRs are now associated with svc_phone services via svc_phone.phonenum
 634   #return () unless $self->svc_x->isa('FS::svc_phone');
 635   return () unless $self->part_svc->svcdb eq 'svc_phone';
 636   my $number = $self->svc_x->phonenum;
 637
 638   my @cdrs =
 639     qsearch( {
 640       'table'      => 'cdr',
 641       'hashref'    => { 'freesidestatus' => '',
 642                         'charged_party'  => $number
 643                       },
 644       'extra_sql'  => 'FOR UPDATE',
 645     } );
 646
 647   if ( length($default_prefix) ) {
 648     push @cdrs,
 649       qsearch( {
 650         'table'      => 'cdr',
 651         'hashref'    => { 'freesidestatus' => '',
 652                           'charged_party'  => "$default_prefix$number",
 653                         },
 654         'extra_sql'  => 'FOR UPDATE',
 655       } );
 656   }
 657
 658   #astricon hack?  config option?
 659   push @cdrs,
 660     qsearch( {
 661       'table'        => 'cdr',
 662       'hashref'      => { 'freesidestatus' => '',
 663                           'src'            => $number,
 664                         },
 665       'extra_sql'    => 'FOR UPDATE',
 666      } );
 667
 668   if ( length($default_prefix) ) {
 669     push @cdrs,
 670       qsearch( {
 671         'table'        => 'cdr',
 672         'hashref'      => { 'freesidestatus' => '',
 673                             'src'            => "$default_prefix$number",
 674                         },
 675         'extra_sql'    => 'FOR UPDATE',
 676        } );
 677   }
 678
 679   @cdrs;
 680 }
 681
 682 =back
 683
 684 =head1 BUGS
 685
 686 Behaviour of changing the svcpart of cust_svc records is undefined and should
 687 possibly be prohibited, and pkg_svc records are not checked.
 688
 689 pkg_svc records are not checked in general (here).
 690
 691 Deleting this record doesn't check or delete the svc_* record associated
 692 with this record.
 693
 694 In seconds_since_sqlradacct, specifying a DATASRC/USERNAME/PASSWORD instead of
 695 a DBI database handle is not yet implemented.
 696
 697 =head1 SEE ALSO
 698
 699 L<FS::Record>, L<FS::cust_pkg>, L<FS::part_svc>, L<FS::pkg_svc>,
 700 schema.html from the base documentation
 701
 702 =cut
 703
 704 1;
 705