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