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 );
   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     my $error = $svc->cancel;
 136     if ( $error ) {
 137       $dbh->rollback if $oldAutoCommit;
 138       return "Error canceling service: $error";
 139     }
 140     $error = $svc->delete;
 141     if ( $error ) {
 142       $dbh->rollback if $oldAutoCommit;
 143       return "Error deleting service: $error";
 144     }
 145   }
 146
 147   my $error = $self->delete;
 148   if ( $error ) {
 149     $dbh->rollback if $oldAutoCommit;
 150     return "Error deleting cust_svc: $error";
 151   }
 152
 153   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 154
 155   ''; #no errors
 156
 157 }
 158
 159 =item overlimit [ ACTION ]
 160
 161 Retrieves or sets the overlimit date.  If ACTION is absent, return
 162 the present value of overlimit.  If ACTION is present, it can
 163 have the value 'suspend' or 'unsuspend'.  In the case of 'suspend' overlimit
 164 is set to the current time if it is not already set.  The 'unsuspend' value
 165 causes the time to be cleared.
 166
 167 If there is an error on setting, returns the error, otherwise returns false.
 168
 169 =cut
 170
 171 sub overlimit {
 172   my $self = shift;
 173   my $action = shift or return $self->getfield('overlimit');
 174
 175   local $SIG{HUP} = 'IGNORE';
 176   local $SIG{INT} = 'IGNORE';
 177   local $SIG{QUIT} = 'IGNORE';
 178   local $SIG{TERM} = 'IGNORE';
 179   local $SIG{TSTP} = 'IGNORE';
 180   local $SIG{PIPE} = 'IGNORE';
 181
 182   my $oldAutoCommit = $FS::UID::AutoCommit;
 183   local $FS::UID::AutoCommit = 0;
 184   my $dbh = dbh;
 185
 186   if ( $action eq 'suspend' ) {
 187     $self->setfield('overlimit', time) unless $self->getfield('overlimit');
 188   }elsif ( $action eq 'unsuspend' ) {
 189     $self->setfield('overlimit', '');
 190   }else{
 191     die "unexpected action value: $action";
 192   }
 193
 194   local $ignore_quantity = 1;
 195   my $error = $self->replace;
 196   if ( $error ) {
 197     $dbh->rollback if $oldAutoCommit;
 198     return "Error setting overlimit: $error";
 199   }
 200
 201   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 202
 203   ''; #no errors
 204
 205 }
 206
 207 =item replace OLD_RECORD
 208
 209 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 210 returns the error, otherwise returns false.
 211
 212 =cut
 213
 214 sub replace {
 215   my ( $new, $old ) = ( shift, shift );
 216
 217   local $SIG{HUP} = 'IGNORE';
 218   local $SIG{INT} = 'IGNORE';
 219   local $SIG{QUIT} = 'IGNORE';
 220   local $SIG{TERM} = 'IGNORE';
 221   local $SIG{TSTP} = 'IGNORE';
 222   local $SIG{PIPE} = 'IGNORE';
 223
 224   my $oldAutoCommit = $FS::UID::AutoCommit;
 225   local $FS::UID::AutoCommit = 0;
 226   my $dbh = dbh;
 227
 228   $old = $new->replace_old unless defined($old);
 229
 230   if ( $new->svcpart != $old->svcpart ) {
 231     my $svc_x = $new->svc_x;
 232     my $new_svc_x = ref($svc_x)->new({$svc_x->hash, svcpart=>$new->svcpart });
 233     local($FS::Record::nowarn_identical) = 1;
 234     my $error = $new_svc_x->replace($svc_x);
 235     if ( $error ) {
 236       $dbh->rollback if $oldAutoCommit;
 237       return $error if $error;
 238     }
 239   }
 240
 241   my $error = $new->SUPER::replace($old);
 242   if ( $error ) {
 243     $dbh->rollback if $oldAutoCommit;
 244     return $error if $error;
 245   }
 246
 247   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 248   ''; #no error
 249
 250 }
 251
 252 =item check
 253
 254 Checks all fields to make sure this is a valid service.  If there is an error,
 255 returns the error, otherwise returns false.  Called by the insert and
 256 replace methods.
 257
 258 =cut
 259
 260 sub check {
 261   my $self = shift;
 262
 263   my $error =
 264     $self->ut_numbern('svcnum')
 265     || $self->ut_numbern('pkgnum')
 266     || $self->ut_number('svcpart')
 267     || $self->ut_numbern('overlimit')
 268   ;
 269   return $error if $error;
 270
 271   my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } );
 272   return "Unknown svcpart" unless $part_svc;
 273
 274   if ( $self->pkgnum ) {
 275     my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
 276     return "Unknown pkgnum" unless $cust_pkg;
 277     my $pkg_svc = qsearchs( 'pkg_svc', {
 278       'pkgpart' => $cust_pkg->pkgpart,
 279       'svcpart' => $self->svcpart,
 280     });
 281     # or new FS::pkg_svc ( { 'pkgpart'  => $cust_pkg->pkgpart,
 282     #                        'svcpart'  => $self->svcpart,
 283     #                        'quantity' => 0                   } );
 284     my $quantity = $pkg_svc ? $pkg_svc->quantity : 0;
 285
 286     my @cust_svc = qsearch('cust_svc', {
 287       'pkgnum'  => $self->pkgnum,
 288       'svcpart' => $self->svcpart,
 289     });
 290     return "Already ". scalar(@cust_svc). " ". $part_svc->svc.
 291            " services for pkgnum ". $self->pkgnum
 292       if scalar(@cust_svc) >= $quantity && !$ignore_quantity;
 293   }
 294
 295   $self->SUPER::check;
 296 }
 297
 298 =item part_svc
 299
 300 Returns the definition for this service, as a FS::part_svc object (see
 301 L<FS::part_svc>).
 302
 303 =cut
 304
 305 sub part_svc {
 306   my $self = shift;
 307   $self->{'_svcpart'}
 308     ? $self->{'_svcpart'}
 309     : qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } );
 310 }
 311
 312 =item cust_pkg
 313
 314 Returns the package this service belongs to, as a FS::cust_pkg object (see
 315 L<FS::cust_pkg>).
 316
 317 =cut
 318
 319 sub cust_pkg {
 320   my $self = shift;
 321   qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
 322 }
 323
 324 =item label
 325
 326 Returns a list consisting of:
 327 - The name of this service (from part_svc)
 328 - A meaningful identifier (username, domain, or mail alias)
 329 - The table name (i.e. svc_domain) for this service
 330 - svcnum
 331
 332 Usage example:
 333
 334   my($label, $value, $svcdb) = $cust_svc->label;
 335
 336 =cut
 337
 338 sub label {
 339   my $self = shift;
 340   carp "FS::cust_svc::label called on $self" if $DEBUG;
 341   my $svc_x = $self->svc_x
 342     or return "can't find ". $self->part_svc->svcdb. '.svcnum '. $self->svcnum;
 343
 344   $self->_svc_label($svc_x);
 345 }
 346
 347 sub _svc_label {
 348   my( $self, $svc_x ) = ( shift, shift );
 349
 350   (
 351     $self->part_svc->svc,
 352     $svc_x->label(@_),
 353     $self->part_svc->svcdb,
 354     $self->svcnum
 355   );
 356
 357 }
 358
 359 =item svc_x
 360
 361 Returns the FS::svc_XXX object for this service (i.e. an FS::svc_acct object or
 362 FS::svc_domain object, etc.)
 363
 364 =cut
 365
 366 sub svc_x {
 367   my $self = shift;
 368   my $svcdb = $self->part_svc->svcdb;
 369   if ( $svcdb eq 'svc_acct' && $self->{'_svc_acct'} ) {
 370     $self->{'_svc_acct'};
 371   } else {
 372     require "FS/$svcdb.pm";
 373     warn "$me svc_x: part_svc.svcpart ". $self->part_svc->svcpart.
 374          ", so searching for $svcdb.svcnum ". $self->svcnum. "\n"
 375       if $DEBUG;
 376     qsearchs( $svcdb, { 'svcnum' => $self->svcnum } );
 377   }
 378 }
 379
 380 =item seconds_since TIMESTAMP
 381
 382 See L<FS::svc_acct/seconds_since>.  Equivalent to
 383 $cust_svc->svc_x->seconds_since, but more efficient.  Meaningless for records
 384 where B<svcdb> is not "svc_acct".
 385
 386 =cut
 387
 388 #note: implementation here, POD in FS::svc_acct
 389 sub seconds_since {
 390   my($self, $since) = @_;
 391   my $dbh = dbh;
 392   my $sth = $dbh->prepare(' SELECT SUM(logout-login) FROM session
 393                               WHERE svcnum = ?
 394                                 AND login >= ?
 395                                 AND logout IS NOT NULL'
 396   ) or die $dbh->errstr;
 397   $sth->execute($self->svcnum, $since) or die $sth->errstr;
 398   $sth->fetchrow_arrayref->[0];
 399 }
 400
 401 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 402
 403 See L<FS::svc_acct/seconds_since_sqlradacct>.  Equivalent to
 404 $cust_svc->svc_x->seconds_since_sqlradacct, but more efficient.  Meaningless
 405 for records where B<svcdb> is not "svc_acct".
 406
 407 =cut
 408
 409 #note: implementation here, POD in FS::svc_acct
 410 sub seconds_since_sqlradacct {
 411   my($self, $start, $end) = @_;
 412
 413   my $svc_x = $self->svc_x;
 414
 415   my @part_export = $self->part_svc->part_export_usage;
 416   die "no accounting-capable exports are enabled for ". $self->part_svc->svc.
 417       " service definition"
 418     unless @part_export;
 419     #or return undef;
 420
 421   my $seconds = 0;
 422   foreach my $part_export ( @part_export ) {
 423
 424     next if $part_export->option('ignore_accounting');
 425
 426     my $dbh = DBI->connect( map { $part_export->option($_) }
 427                             qw(datasrc username password)    )
 428       or die "can't connect to sqlradius database: ". $DBI::errstr;
 429
 430     #select a unix time conversion function based on database type
 431     my $str2time;
 432     if ( $dbh->{Driver}->{Name} =~ /^mysql(PP)?$/ ) {
 433       $str2time = 'UNIX_TIMESTAMP(';
 434     } elsif ( $dbh->{Driver}->{Name} eq 'Pg' ) {
 435       $str2time = 'EXTRACT( EPOCH FROM ';
 436     } else {
 437       warn "warning: unknown database type ". $dbh->{Driver}->{Name}.
 438            "; guessing how to convert to UNIX timestamps";
 439       $str2time = 'extract(epoch from ';
 440     }
 441
 442     my $username = $part_export->export_username($svc_x);
 443
 444     my $query;
 445
 446     #find closed sessions completely within the given range
 447     my $sth = $dbh->prepare("SELECT SUM(acctsessiontime)
 448                                FROM radacct
 449                                WHERE UserName = ?
 450                                  AND $str2time AcctStartTime) >= ?
 451                                  AND $str2time AcctStopTime ) <  ?
 452                                  AND $str2time AcctStopTime ) > 0
 453                                  AND AcctStopTime IS NOT NULL"
 454     ) or die $dbh->errstr;
 455     $sth->execute($username, $start, $end) or die $sth->errstr;
 456     my $regular = $sth->fetchrow_arrayref->[0];
 457
 458     #find open sessions which start in the range, count session start->range end
 459     $query = "SELECT SUM( ? - $str2time AcctStartTime ) )
 460                 FROM radacct
 461                 WHERE UserName = ?
 462                   AND $str2time AcctStartTime ) >= ?
 463                   AND $str2time AcctStartTime ) <  ?
 464                   AND ( ? - $str2time AcctStartTime ) ) < 86400
 465                   AND (    $str2time AcctStopTime ) = 0
 466                                     OR AcctStopTime IS NULL )";
 467     $sth = $dbh->prepare($query) or die $dbh->errstr;
 468     $sth->execute($end, $username, $start, $end, $end)
 469       or die $sth->errstr. " executing query $query";
 470     my $start_during = $sth->fetchrow_arrayref->[0];
 471
 472     #find closed sessions which start before the range but stop during,
 473     #count range start->session end
 474     $sth = $dbh->prepare("SELECT SUM( $str2time AcctStopTime ) - ? )
 475                             FROM radacct
 476                             WHERE UserName = ?
 477                               AND $str2time AcctStartTime ) < ?
 478                               AND $str2time AcctStopTime  ) >= ?
 479                               AND $str2time AcctStopTime  ) <  ?
 480                               AND $str2time AcctStopTime ) > 0
 481                               AND AcctStopTime IS NOT NULL"
 482     ) or die $dbh->errstr;
 483     $sth->execute($start, $username, $start, $start, $end ) or die $sth->errstr;
 484     my $end_during = $sth->fetchrow_arrayref->[0];
 485
 486     #find closed (not anymore - or open) sessions which start before the range
 487     # but stop after, or are still open, count range start->range end
 488     # don't count open sessions (probably missing stop record)
 489     $sth = $dbh->prepare("SELECT COUNT(*)
 490                             FROM radacct
 491                             WHERE UserName = ?
 492                               AND $str2time AcctStartTime ) < ?
 493                               AND ( $str2time AcctStopTime ) >= ?
 494                                                                   )"
 495                               #      OR AcctStopTime =  0
 496                               #      OR AcctStopTime IS NULL       )"
 497     ) or die $dbh->errstr;
 498     $sth->execute($username, $start, $end ) or die $sth->errstr;
 499     my $entire_range = ($end-$start) * $sth->fetchrow_arrayref->[0];
 500
 501     $seconds += $regular + $end_during + $start_during + $entire_range;
 502
 503   }
 504
 505   $seconds;
 506
 507 }
 508
 509 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 510
 511 See L<FS::svc_acct/attribute_since_sqlradacct>.  Equivalent to
 512 $cust_svc->svc_x->attribute_since_sqlradacct, but more efficient.  Meaningless
 513 for records where B<svcdb> is not "svc_acct".
 514
 515 =cut
 516
 517 #note: implementation here, POD in FS::svc_acct
 518 #(false laziness w/seconds_since_sqlradacct above)
 519 sub attribute_since_sqlradacct {
 520   my($self, $start, $end, $attrib) = @_;
 521
 522   my $svc_x = $self->svc_x;
 523
 524   my @part_export = $self->part_svc->part_export_usage;
 525   die "no accounting-capable exports are enabled for ". $self->part_svc->svc.
 526       " service definition"
 527     unless @part_export;
 528     #or return undef;
 529
 530   my $sum = 0;
 531
 532   foreach my $part_export ( @part_export ) {
 533
 534     next if $part_export->option('ignore_accounting');
 535
 536     my $dbh = DBI->connect( map { $part_export->option($_) }
 537                             qw(datasrc username password)    )
 538       or die "can't connect to sqlradius database: ". $DBI::errstr;
 539
 540     #select a unix time conversion function based on database type
 541     my $str2time;
 542     if ( $dbh->{Driver}->{Name} =~ /^mysql(PP)?$/ ) {
 543       $str2time = 'UNIX_TIMESTAMP(';
 544     } elsif ( $dbh->{Driver}->{Name} eq 'Pg' ) {
 545       $str2time = 'EXTRACT( EPOCH FROM ';
 546     } else {
 547       warn "warning: unknown database type ". $dbh->{Driver}->{Name}.
 548            "; guessing how to convert to UNIX timestamps";
 549       $str2time = 'extract(epoch from ';
 550     }
 551
 552     my $username = $part_export->export_username($svc_x);
 553
 554     my $sth = $dbh->prepare("SELECT SUM($attrib)
 555                                FROM radacct
 556                                WHERE UserName = ?
 557                                  AND $str2time AcctStopTime ) >= ?
 558                                  AND $str2time AcctStopTime ) <  ?
 559                                  AND AcctStopTime IS NOT NULL"
 560     ) or die $dbh->errstr;
 561     $sth->execute($username, $start, $end) or die $sth->errstr;
 562
 563     $sum += $sth->fetchrow_arrayref->[0];
 564
 565   }
 566
 567   $sum;
 568
 569 }
 570
 571 =item get_session_history TIMESTAMP_START TIMESTAMP_END
 572
 573 See L<FS::svc_acct/get_session_history>.  Equivalent to
 574 $cust_svc->svc_x->get_session_history, but more efficient.  Meaningless for
 575 records where B<svcdb> is not "svc_acct".
 576
 577 =cut
 578
 579 sub get_session_history {
 580   my($self, $start, $end, $attrib) = @_;
 581
 582   #$attrib ???
 583
 584   my @part_export = $self->part_svc->part_export_usage;
 585   die "no accounting-capable exports are enabled for ". $self->part_svc->svc.
 586       " service definition"
 587     unless @part_export;
 588     #or return undef;
 589
 590   my @sessions = ();
 591
 592   foreach my $part_export ( @part_export ) {
 593     push @sessions,
 594       @{ $part_export->usage_sessions( $start, $end, $self->svc_x ) };
 595   }
 596
 597   @sessions;
 598
 599 }
 600
 601 =item get_cdrs_for_update
 602
 603 Returns (and SELECTs "FOR UPDATE") all unprocessed (freesidestatus NULL) CDR
 604 objects (see L<FS::cdr>) associated with this service.
 605
 606 Currently CDRs are associated with svc_acct services via a DID in the
 607 username.  This part is rather tenative and still subject to change...
 608
 609 =cut
 610
 611 sub get_cdrs_for_update {
 612   my($self, %options) = @_;
 613
 614   my $default_prefix = $options{'default_prefix'};
 615
 616   #CDRs are now associated with svc_phone services via svc_phone.phonenum
 617   #return () unless $self->svc_x->isa('FS::svc_phone');
 618   return () unless $self->part_svc->svcdb eq 'svc_phone';
 619   my $number = $self->svc_x->phonenum;
 620
 621   my @cdrs =
 622     qsearch( {
 623       'table'      => 'cdr',
 624       'hashref'    => { 'freesidestatus' => '',
 625                         'charged_party'  => $number
 626                       },
 627       'extra_sql'  => 'FOR UPDATE',
 628     } );
 629
 630   if ( length($default_prefix) ) {
 631     push @cdrs,
 632       qsearch( {
 633         'table'      => 'cdr',
 634         'hashref'    => { 'freesidestatus' => '',
 635                           'charged_party'  => "$default_prefix$number",
 636                         },
 637         'extra_sql'  => 'FOR UPDATE',
 638       } );
 639   }
 640
 641   @cdrs;
 642 }
 643
 644 =item pkg_svc
 645
 646 Returns the pkg_svc record for for this service, if applicable.
 647
 648 =cut
 649
 650 sub pkg_svc {
 651   my $self = shift;
 652   my $cust_pkg = $self->cust_pkg;
 653   return undef unless $cust_pkg;
 654
 655   qsearchs( 'pkg_svc', { 'svcpart' => $self->svcpart,
 656                          'pkgpart' => $cust_pkg->pkgpart,
 657                        }
 658           );
 659 }
 660
 661 =back
 662
 663 =head1 BUGS
 664
 665 Behaviour of changing the svcpart of cust_svc records is undefined and should
 666 possibly be prohibited, and pkg_svc records are not checked.
 667
 668 pkg_svc records are not checked in general (here).
 669
 670 Deleting this record doesn't check or delete the svc_* record associated
 671 with this record.
 672
 673 In seconds_since_sqlradacct, specifying a DATASRC/USERNAME/PASSWORD instead of
 674 a DBI database handle is not yet implemented.
 675
 676 =head1 SEE ALSO
 677
 678 L<FS::Record>, L<FS::cust_pkg>, L<FS::part_svc>, L<FS::pkg_svc>,
 679 schema.html from the base documentation
 680
 681 =cut
 682
 683 1;
 684