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 pkg_svc
 325
 326 Returns the pkg_svc record for for this service, if applicable.
 327
 328 =cut
 329
 330 sub pkg_svc {
 331   my $self = shift;
 332   my $cust_pkg = $self->cust_pkg;
 333   return undef unless $cust_pkg;
 334
 335   qsearchs( 'pkg_svc', { 'svcpart' => $self->svcpart,
 336                          'pkgpart' => $cust_pkg->pkgpart,
 337                        }
 338           );
 339 }
 340
 341 =item date_inserted
 342
 343 Returns the date this service was inserted.
 344
 345 =cut
 346
 347 sub date_inserted {
 348   my $self = shift;
 349   $self->h_date('insert');
 350 }
 351
 352 =item label
 353
 354 Returns a list consisting of:
 355 - The name of this service (from part_svc)
 356 - A meaningful identifier (username, domain, or mail alias)
 357 - The table name (i.e. svc_domain) for this service
 358 - svcnum
 359
 360 Usage example:
 361
 362   my($label, $value, $svcdb) = $cust_svc->label;
 363
 364 =cut
 365
 366 sub label {
 367   my $self = shift;
 368   carp "FS::cust_svc::label called on $self" if $DEBUG;
 369   my $svc_x = $self->svc_x
 370     or return "can't find ". $self->part_svc->svcdb. '.svcnum '. $self->svcnum;
 371
 372   $self->_svc_label($svc_x);
 373 }
 374
 375 sub _svc_label {
 376   my( $self, $svc_x ) = ( shift, shift );
 377
 378   (
 379     $self->part_svc->svc,
 380     $svc_x->label(@_),
 381     $self->part_svc->svcdb,
 382     $self->svcnum
 383   );
 384
 385 }
 386
 387 =item svc_x
 388
 389 Returns the FS::svc_XXX object for this service (i.e. an FS::svc_acct object or
 390 FS::svc_domain object, etc.)
 391
 392 =cut
 393
 394 sub svc_x {
 395   my $self = shift;
 396   my $svcdb = $self->part_svc->svcdb;
 397   if ( $svcdb eq 'svc_acct' && $self->{'_svc_acct'} ) {
 398     $self->{'_svc_acct'};
 399   } else {
 400     require "FS/$svcdb.pm";
 401     warn "$me svc_x: part_svc.svcpart ". $self->part_svc->svcpart.
 402          ", so searching for $svcdb.svcnum ". $self->svcnum. "\n"
 403       if $DEBUG;
 404     qsearchs( $svcdb, { 'svcnum' => $self->svcnum } );
 405   }
 406 }
 407
 408 =item seconds_since TIMESTAMP
 409
 410 See L<FS::svc_acct/seconds_since>.  Equivalent to
 411 $cust_svc->svc_x->seconds_since, but more efficient.  Meaningless for records
 412 where B<svcdb> is not "svc_acct".
 413
 414 =cut
 415
 416 #note: implementation here, POD in FS::svc_acct
 417 sub seconds_since {
 418   my($self, $since) = @_;
 419   my $dbh = dbh;
 420   my $sth = $dbh->prepare(' SELECT SUM(logout-login) FROM session
 421                               WHERE svcnum = ?
 422                                 AND login >= ?
 423                                 AND logout IS NOT NULL'
 424   ) or die $dbh->errstr;
 425   $sth->execute($self->svcnum, $since) or die $sth->errstr;
 426   $sth->fetchrow_arrayref->[0];
 427 }
 428
 429 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 430
 431 See L<FS::svc_acct/seconds_since_sqlradacct>.  Equivalent to
 432 $cust_svc->svc_x->seconds_since_sqlradacct, but more efficient.  Meaningless
 433 for records where B<svcdb> is not "svc_acct".
 434
 435 =cut
 436
 437 #note: implementation here, POD in FS::svc_acct
 438 sub seconds_since_sqlradacct {
 439   my($self, $start, $end) = @_;
 440
 441   my $svc_x = $self->svc_x;
 442
 443   my @part_export = $self->part_svc->part_export_usage;
 444   die "no accounting-capable exports are enabled for ". $self->part_svc->svc.
 445       " service definition"
 446     unless @part_export;
 447     #or return undef;
 448
 449   my $seconds = 0;
 450   foreach my $part_export ( @part_export ) {
 451
 452     next if $part_export->option('ignore_accounting');
 453
 454     my $dbh = DBI->connect( map { $part_export->option($_) }
 455                             qw(datasrc username password)    )
 456       or die "can't connect to sqlradius database: ". $DBI::errstr;
 457
 458     #select a unix time conversion function based on database type
 459     my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
 460
 461     my $username = $part_export->export_username($svc_x);
 462
 463     my $query;
 464
 465     #find closed sessions completely within the given range
 466     my $sth = $dbh->prepare("SELECT SUM(acctsessiontime)
 467                                FROM radacct
 468                                WHERE UserName = ?
 469                                  AND $str2time AcctStartTime) >= ?
 470                                  AND $str2time AcctStopTime ) <  ?
 471                                  AND $str2time AcctStopTime ) > 0
 472                                  AND AcctStopTime IS NOT NULL"
 473     ) or die $dbh->errstr;
 474     $sth->execute($username, $start, $end) or die $sth->errstr;
 475     my $regular = $sth->fetchrow_arrayref->[0];
 476
 477     #find open sessions which start in the range, count session start->range end
 478     $query = "SELECT SUM( ? - $str2time AcctStartTime ) )
 479                 FROM radacct
 480                 WHERE UserName = ?
 481                   AND $str2time AcctStartTime ) >= ?
 482                   AND $str2time AcctStartTime ) <  ?
 483                   AND ( ? - $str2time AcctStartTime ) ) < 86400
 484                   AND (    $str2time AcctStopTime ) = 0
 485                                     OR AcctStopTime IS NULL )";
 486     $sth = $dbh->prepare($query) or die $dbh->errstr;
 487     $sth->execute($end, $username, $start, $end, $end)
 488       or die $sth->errstr. " executing query $query";
 489     my $start_during = $sth->fetchrow_arrayref->[0];
 490
 491     #find closed sessions which start before the range but stop during,
 492     #count range start->session end
 493     $sth = $dbh->prepare("SELECT SUM( $str2time AcctStopTime ) - ? )
 494                             FROM radacct
 495                             WHERE UserName = ?
 496                               AND $str2time AcctStartTime ) < ?
 497                               AND $str2time AcctStopTime  ) >= ?
 498                               AND $str2time AcctStopTime  ) <  ?
 499                               AND $str2time AcctStopTime ) > 0
 500                               AND AcctStopTime IS NOT NULL"
 501     ) or die $dbh->errstr;
 502     $sth->execute($start, $username, $start, $start, $end ) or die $sth->errstr;
 503     my $end_during = $sth->fetchrow_arrayref->[0];
 504
 505     #find closed (not anymore - or open) sessions which start before the range
 506     # but stop after, or are still open, count range start->range end
 507     # don't count open sessions (probably missing stop record)
 508     $sth = $dbh->prepare("SELECT COUNT(*)
 509                             FROM radacct
 510                             WHERE UserName = ?
 511                               AND $str2time AcctStartTime ) < ?
 512                               AND ( $str2time AcctStopTime ) >= ?
 513                                                                   )"
 514                               #      OR AcctStopTime =  0
 515                               #      OR AcctStopTime IS NULL       )"
 516     ) or die $dbh->errstr;
 517     $sth->execute($username, $start, $end ) or die $sth->errstr;
 518     my $entire_range = ($end-$start) * $sth->fetchrow_arrayref->[0];
 519
 520     $seconds += $regular + $end_during + $start_during + $entire_range;
 521
 522   }
 523
 524   $seconds;
 525
 526 }
 527
 528 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 529
 530 See L<FS::svc_acct/attribute_since_sqlradacct>.  Equivalent to
 531 $cust_svc->svc_x->attribute_since_sqlradacct, but more efficient.  Meaningless
 532 for records where B<svcdb> is not "svc_acct".
 533
 534 =cut
 535
 536 #note: implementation here, POD in FS::svc_acct
 537 #(false laziness w/seconds_since_sqlradacct above)
 538 sub attribute_since_sqlradacct {
 539   my($self, $start, $end, $attrib) = @_;
 540
 541   my $svc_x = $self->svc_x;
 542
 543   my @part_export = $self->part_svc->part_export_usage;
 544   die "no accounting-capable exports are enabled for ". $self->part_svc->svc.
 545       " service definition"
 546     unless @part_export;
 547     #or return undef;
 548
 549   my $sum = 0;
 550
 551   foreach my $part_export ( @part_export ) {
 552
 553     next if $part_export->option('ignore_accounting');
 554
 555     my $dbh = DBI->connect( map { $part_export->option($_) }
 556                             qw(datasrc username password)    )
 557       or die "can't connect to sqlradius database: ". $DBI::errstr;
 558
 559     #select a unix time conversion function based on database type
 560     my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
 561
 562     my $username = $part_export->export_username($svc_x);
 563
 564     my $sth = $dbh->prepare("SELECT SUM($attrib)
 565                                FROM radacct
 566                                WHERE UserName = ?
 567                                  AND $str2time AcctStopTime ) >= ?
 568                                  AND $str2time AcctStopTime ) <  ?
 569                                  AND AcctStopTime IS NOT NULL"
 570     ) or die $dbh->errstr;
 571     $sth->execute($username, $start, $end) or die $sth->errstr;
 572
 573     $sum += $sth->fetchrow_arrayref->[0];
 574
 575   }
 576
 577   $sum;
 578
 579 }
 580
 581 =item get_session_history TIMESTAMP_START TIMESTAMP_END
 582
 583 See L<FS::svc_acct/get_session_history>.  Equivalent to
 584 $cust_svc->svc_x->get_session_history, but more efficient.  Meaningless for
 585 records where B<svcdb> is not "svc_acct".
 586
 587 =cut
 588
 589 sub get_session_history {
 590   my($self, $start, $end, $attrib) = @_;
 591
 592   #$attrib ???
 593
 594   my @part_export = $self->part_svc->part_export_usage;
 595   die "no accounting-capable exports are enabled for ". $self->part_svc->svc.
 596       " service definition"
 597     unless @part_export;
 598     #or return undef;
 599
 600   my @sessions = ();
 601
 602   foreach my $part_export ( @part_export ) {
 603     push @sessions,
 604       @{ $part_export->usage_sessions( $start, $end, $self->svc_x ) };
 605   }
 606
 607   @sessions;
 608
 609 }
 610
 611 =item get_cdrs_for_update
 612
 613 Returns (and SELECTs "FOR UPDATE") all unprocessed (freesidestatus NULL) CDR
 614 objects (see L<FS::cdr>) associated with this service.
 615
 616 CDRs are associated with svc_phone services via svc_phone.phonenum
 617
 618 =cut
 619
 620 sub get_cdrs_for_update {
 621   my($self, %options) = @_;
 622
 623   my $default_prefix = $options{'default_prefix'};
 624
 625   #CDRs are now associated with svc_phone services via svc_phone.phonenum
 626   #return () unless $self->svc_x->isa('FS::svc_phone');
 627   return () unless $self->part_svc->svcdb eq 'svc_phone';
 628   my $number = $self->svc_x->phonenum;
 629
 630   my @cdrs =
 631     qsearch( {
 632       'table'      => 'cdr',
 633       'hashref'    => { 'freesidestatus' => '',
 634                         'charged_party'  => $number
 635                       },
 636       'extra_sql'  => 'FOR UPDATE',
 637     } );
 638
 639   if ( length($default_prefix) ) {
 640     push @cdrs,
 641       qsearch( {
 642         'table'      => 'cdr',
 643         'hashref'    => { 'freesidestatus' => '',
 644                           'charged_party'  => "$default_prefix$number",
 645                         },
 646         'extra_sql'  => 'FOR UPDATE',
 647       } );
 648   }
 649
 650   #astricon hack?  config option?
 651   push @cdrs,
 652     qsearch( {
 653       'table'        => 'cdr',
 654       'hashref'      => { 'freesidestatus' => '',
 655                           'src'            => $number,
 656                         },
 657       'extra_sql'    => 'FOR UPDATE',
 658      } );
 659
 660   if ( length($default_prefix) ) {
 661     push @cdrs,
 662       qsearch( {
 663         'table'        => 'cdr',
 664         'hashref'      => { 'freesidestatus' => '',
 665                             'src'            => "$default_prefix$number",
 666                         },
 667         'extra_sql'    => 'FOR UPDATE',
 668        } );
 669   }
 670
 671   @cdrs;
 672 }
 673
 674 =back
 675
 676 =head1 BUGS
 677
 678 Behaviour of changing the svcpart of cust_svc records is undefined and should
 679 possibly be prohibited, and pkg_svc records are not checked.
 680
 681 pkg_svc records are not checked in general (here).
 682
 683 Deleting this record doesn't check or delete the svc_* record associated
 684 with this record.
 685
 686 In seconds_since_sqlradacct, specifying a DATASRC/USERNAME/PASSWORD instead of
 687 a DBI database handle is not yet implemented.
 688
 689 =head1 SEE ALSO
 690
 691 L<FS::Record>, L<FS::cust_pkg>, L<FS::part_svc>, L<FS::pkg_svc>,
 692 schema.html from the base documentation
 693
 694 =cut
 695
 696 1;
 697