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     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 = str2time_sql( $dbh->{Driver}->{Name} );
 432
 433     my $username = $part_export->export_username($svc_x);
 434
 435     my $query;
 436
 437     #find closed sessions completely within the given range
 438     my $sth = $dbh->prepare("SELECT SUM(acctsessiontime)
 439                                FROM radacct
 440                                WHERE UserName = ?
 441                                  AND $str2time AcctStartTime) >= ?
 442                                  AND $str2time AcctStopTime ) <  ?
 443                                  AND $str2time AcctStopTime ) > 0
 444                                  AND AcctStopTime IS NOT NULL"
 445     ) or die $dbh->errstr;
 446     $sth->execute($username, $start, $end) or die $sth->errstr;
 447     my $regular = $sth->fetchrow_arrayref->[0];
 448
 449     #find open sessions which start in the range, count session start->range end
 450     $query = "SELECT SUM( ? - $str2time AcctStartTime ) )
 451                 FROM radacct
 452                 WHERE UserName = ?
 453                   AND $str2time AcctStartTime ) >= ?
 454                   AND $str2time AcctStartTime ) <  ?
 455                   AND ( ? - $str2time AcctStartTime ) ) < 86400
 456                   AND (    $str2time AcctStopTime ) = 0
 457                                     OR AcctStopTime IS NULL )";
 458     $sth = $dbh->prepare($query) or die $dbh->errstr;
 459     $sth->execute($end, $username, $start, $end, $end)
 460       or die $sth->errstr. " executing query $query";
 461     my $start_during = $sth->fetchrow_arrayref->[0];
 462
 463     #find closed sessions which start before the range but stop during,
 464     #count range start->session end
 465     $sth = $dbh->prepare("SELECT SUM( $str2time AcctStopTime ) - ? )
 466                             FROM radacct
 467                             WHERE UserName = ?
 468                               AND $str2time AcctStartTime ) < ?
 469                               AND $str2time AcctStopTime  ) >= ?
 470                               AND $str2time AcctStopTime  ) <  ?
 471                               AND $str2time AcctStopTime ) > 0
 472                               AND AcctStopTime IS NOT NULL"
 473     ) or die $dbh->errstr;
 474     $sth->execute($start, $username, $start, $start, $end ) or die $sth->errstr;
 475     my $end_during = $sth->fetchrow_arrayref->[0];
 476
 477     #find closed (not anymore - or open) sessions which start before the range
 478     # but stop after, or are still open, count range start->range end
 479     # don't count open sessions (probably missing stop record)
 480     $sth = $dbh->prepare("SELECT COUNT(*)
 481                             FROM radacct
 482                             WHERE UserName = ?
 483                               AND $str2time AcctStartTime ) < ?
 484                               AND ( $str2time AcctStopTime ) >= ?
 485                                                                   )"
 486                               #      OR AcctStopTime =  0
 487                               #      OR AcctStopTime IS NULL       )"
 488     ) or die $dbh->errstr;
 489     $sth->execute($username, $start, $end ) or die $sth->errstr;
 490     my $entire_range = ($end-$start) * $sth->fetchrow_arrayref->[0];
 491
 492     $seconds += $regular + $end_during + $start_during + $entire_range;
 493
 494   }
 495
 496   $seconds;
 497
 498 }
 499
 500 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 501
 502 See L<FS::svc_acct/attribute_since_sqlradacct>.  Equivalent to
 503 $cust_svc->svc_x->attribute_since_sqlradacct, but more efficient.  Meaningless
 504 for records where B<svcdb> is not "svc_acct".
 505
 506 =cut
 507
 508 #note: implementation here, POD in FS::svc_acct
 509 #(false laziness w/seconds_since_sqlradacct above)
 510 sub attribute_since_sqlradacct {
 511   my($self, $start, $end, $attrib) = @_;
 512
 513   my $svc_x = $self->svc_x;
 514
 515   my @part_export = $self->part_svc->part_export_usage;
 516   die "no accounting-capable exports are enabled for ". $self->part_svc->svc.
 517       " service definition"
 518     unless @part_export;
 519     #or return undef;
 520
 521   my $sum = 0;
 522
 523   foreach my $part_export ( @part_export ) {
 524
 525     next if $part_export->option('ignore_accounting');
 526
 527     my $dbh = DBI->connect( map { $part_export->option($_) }
 528                             qw(datasrc username password)    )
 529       or die "can't connect to sqlradius database: ". $DBI::errstr;
 530
 531     #select a unix time conversion function based on database type
 532     my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
 533
 534     my $username = $part_export->export_username($svc_x);
 535
 536     my $sth = $dbh->prepare("SELECT SUM($attrib)
 537                                FROM radacct
 538                                WHERE UserName = ?
 539                                  AND $str2time AcctStopTime ) >= ?
 540                                  AND $str2time AcctStopTime ) <  ?
 541                                  AND AcctStopTime IS NOT NULL"
 542     ) or die $dbh->errstr;
 543     $sth->execute($username, $start, $end) or die $sth->errstr;
 544
 545     $sum += $sth->fetchrow_arrayref->[0];
 546
 547   }
 548
 549   $sum;
 550
 551 }
 552
 553 =item get_session_history TIMESTAMP_START TIMESTAMP_END
 554
 555 See L<FS::svc_acct/get_session_history>.  Equivalent to
 556 $cust_svc->svc_x->get_session_history, but more efficient.  Meaningless for
 557 records where B<svcdb> is not "svc_acct".
 558
 559 =cut
 560
 561 sub get_session_history {
 562   my($self, $start, $end, $attrib) = @_;
 563
 564   #$attrib ???
 565
 566   my @part_export = $self->part_svc->part_export_usage;
 567   die "no accounting-capable exports are enabled for ". $self->part_svc->svc.
 568       " service definition"
 569     unless @part_export;
 570     #or return undef;
 571
 572   my @sessions = ();
 573
 574   foreach my $part_export ( @part_export ) {
 575     push @sessions,
 576       @{ $part_export->usage_sessions( $start, $end, $self->svc_x ) };
 577   }
 578
 579   @sessions;
 580
 581 }
 582
 583 =item get_cdrs_for_update
 584
 585 Returns (and SELECTs "FOR UPDATE") all unprocessed (freesidestatus NULL) CDR
 586 objects (see L<FS::cdr>) associated with this service.
 587
 588 CDRs are associated with svc_phone services via svc_phone.phonenum
 589
 590 =cut
 591
 592 sub get_cdrs_for_update {
 593   my($self, %options) = @_;
 594
 595   my $default_prefix = $options{'default_prefix'};
 596
 597   #CDRs are now associated with svc_phone services via svc_phone.phonenum
 598   #return () unless $self->svc_x->isa('FS::svc_phone');
 599   return () unless $self->part_svc->svcdb eq 'svc_phone';
 600   my $number = $self->svc_x->phonenum;
 601
 602   my @cdrs =
 603     qsearch( {
 604       'table'      => 'cdr',
 605       'hashref'    => { 'freesidestatus' => '',
 606                         'charged_party'  => $number
 607                       },
 608       'extra_sql'  => 'FOR UPDATE',
 609     } );
 610
 611   if ( length($default_prefix) ) {
 612     push @cdrs,
 613       qsearch( {
 614         'table'      => 'cdr',
 615         'hashref'    => { 'freesidestatus' => '',
 616                           'charged_party'  => "$default_prefix$number",
 617                         },
 618         'extra_sql'  => 'FOR UPDATE',
 619       } );
 620   }
 621
 622   #astricon hack?  config option?
 623   push @cdrs,
 624     qsearch( {
 625       'table'        => 'cdr',
 626       'hashref'      => { 'freesidestatus' => '',
 627                           'src'            => $number,
 628                         },
 629       'extra_sql'    => 'FOR UPDATE',
 630      } );
 631
 632   if ( length($default_prefix) ) {
 633     push @cdrs,
 634       qsearch( {
 635         'table'        => 'cdr',
 636         'hashref'      => { 'freesidestatus' => '',
 637                             'src'            => "$default_prefix$number",
 638                         },
 639         'extra_sql'    => 'FOR UPDATE',
 640        } );
 641   }
 642
 643   @cdrs;
 644 }
 645
 646 =item pkg_svc
 647
 648 Returns the pkg_svc record for for this service, if applicable.
 649
 650 =cut
 651
 652 sub pkg_svc {
 653   my $self = shift;
 654   my $cust_pkg = $self->cust_pkg;
 655   return undef unless $cust_pkg;
 656
 657   qsearchs( 'pkg_svc', { 'svcpart' => $self->svcpart,
 658                          'pkgpart' => $cust_pkg->pkgpart,
 659                        }
 660           );
 661 }
 662
 663 =back
 664
 665 =head1 BUGS
 666
 667 Behaviour of changing the svcpart of cust_svc records is undefined and should
 668 possibly be prohibited, and pkg_svc records are not checked.
 669
 670 pkg_svc records are not checked in general (here).
 671
 672 Deleting this record doesn't check or delete the svc_* record associated
 673 with this record.
 674
 675 In seconds_since_sqlradacct, specifying a DATASRC/USERNAME/PASSWORD instead of
 676 a DBI database handle is not yet implemented.
 677
 678 =head1 SEE ALSO
 679
 680 L<FS::Record>, L<FS::cust_pkg>, L<FS::part_svc>, L<FS::pkg_svc>,
 681 schema.html from the base documentation
 682
 683 =cut
 684
 685 1;
 686