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