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