FS/FS/cust_svc.pm

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