FS/FS/cust_svc.pm

   1 package FS::cust_svc;
   2
   3 use strict;
   4 use vars qw( @ISA );
   5 use Carp qw( cluck );
   6 use FS::Record qw( qsearch qsearchs dbh );
   7 use FS::cust_pkg;
   8 use FS::part_pkg;
   9 use FS::part_svc;
  10 use FS::pkg_svc;
  11 use FS::svc_acct;
  12 use FS::svc_domain;
  13 use FS::svc_forward;
  14 use FS::domain_record;
  15 use FS::part_export;
  16
  17 @ISA = qw( FS::Record );
  18
  19 sub _cache {
  20   my $self = shift;
  21   my ( $hashref, $cache ) = @_;
  22   if ( $hashref->{'username'} ) {
  23     $self->{'_svc_acct'} = FS::svc_acct->new($hashref, '');
  24   }
  25   if ( $hashref->{'svc'} ) {
  26     $self->{'_svcpart'} = FS::part_svc->new($hashref);
  27   }
  28 }
  29
  30 =head1 NAME
  31
  32 FS::cust_svc - Object method for cust_svc objects
  33
  34 =head1 SYNOPSIS
  35
  36   use FS::cust_svc;
  37
  38   $record = new FS::cust_svc \%hash
  39   $record = new FS::cust_svc { 'column' => 'value' };
  40
  41   $error = $record->insert;
  42
  43   $error = $new_record->replace($old_record);
  44
  45   $error = $record->delete;
  46
  47   $error = $record->check;
  48
  49   ($label, $value) = $record->label;
  50
  51 =head1 DESCRIPTION
  52
  53 An FS::cust_svc represents a service.  FS::cust_svc inherits from FS::Record.
  54 The following fields are currently supported:
  55
  56 =over 4
  57
  58 =item svcnum - primary key (assigned automatically for new services)
  59
  60 =item pkgnum - Package (see L<FS::cust_pkg>)
  61
  62 =item svcpart - Service definition (see L<FS::part_svc>)
  63
  64 =back
  65
  66 =head1 METHODS
  67
  68 =over 4
  69
  70 =item new HASHREF
  71
  72 Creates a new service.  To add the refund to the database, see L<"insert">.
  73 Services are normally created by creating FS::svc_ objects (see
  74 L<FS::svc_acct>, L<FS::svc_domain>, and L<FS::svc_forward>, among others).
  75
  76 =cut
  77
  78 sub table { 'cust_svc'; }
  79
  80 =item insert
  81
  82 Adds this service to the database.  If there is an error, returns the error,
  83 otherwise returns false.
  84
  85 =item delete
  86
  87 Deletes this service from the database.  If there is an error, returns the
  88 error, otherwise returns false.  Note that this only removes the cust_svc
  89 record - you should probably use the B<cancel> method instead.
  90
  91 =item cancel
  92
  93 Cancels the relevant service by calling the B<cancel> method of the associated
  94 FS::svc_XXX object (i.e. an FS::svc_acct object or FS::svc_domain object),
  95 deleting the FS::svc_XXX record and then deleting this record.
  96
  97 If there is an error, returns the error, otherwise returns false.
  98
  99 =cut
 100
 101 sub cancel {
 102   my $self = shift;
 103
 104   local $SIG{HUP} = 'IGNORE';
 105   local $SIG{INT} = 'IGNORE';
 106   local $SIG{QUIT} = 'IGNORE';
 107   local $SIG{TERM} = 'IGNORE';
 108   local $SIG{TSTP} = 'IGNORE';
 109   local $SIG{PIPE} = 'IGNORE';
 110
 111   my $oldAutoCommit = $FS::UID::AutoCommit;
 112   local $FS::UID::AutoCommit = 0;
 113   my $dbh = dbh;
 114
 115   my $part_svc = $self->part_svc;
 116
 117   $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 118     $dbh->rollback if $oldAutoCommit;
 119     return "Illegal svcdb value in part_svc!";
 120   };
 121   my $svcdb = $1;
 122   require "FS/$svcdb.pm";
 123
 124   my $svc = $self->svc_x;
 125   if ($svc) {
 126     my $error = $svc->cancel;
 127     if ( $error ) {
 128       $dbh->rollback if $oldAutoCommit;
 129       return "Error canceling service: $error";
 130     }
 131     $error = $svc->delete;
 132     if ( $error ) {
 133       $dbh->rollback if $oldAutoCommit;
 134       return "Error deleting service: $error";
 135     }
 136   }
 137
 138   my $error = $self->delete;
 139   if ( $error ) {
 140     $dbh->rollback if $oldAutoCommit;
 141     return "Error deleting cust_svc: $error";
 142   }
 143
 144   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 145
 146   ''; #no errors
 147
 148 }
 149
 150 =item replace OLD_RECORD
 151
 152 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 153 returns the error, otherwise returns false.
 154
 155 =cut
 156
 157 sub replace {
 158   my ( $new, $old ) = ( shift, shift );
 159
 160   local $SIG{HUP} = 'IGNORE';
 161   local $SIG{INT} = 'IGNORE';
 162   local $SIG{QUIT} = 'IGNORE';
 163   local $SIG{TERM} = 'IGNORE';
 164   local $SIG{TSTP} = 'IGNORE';
 165   local $SIG{PIPE} = 'IGNORE';
 166
 167   my $oldAutoCommit = $FS::UID::AutoCommit;
 168   local $FS::UID::AutoCommit = 0;
 169   my $dbh = dbh;
 170
 171   my $error = $new->SUPER::replace($old);
 172   if ( $error ) {
 173     $dbh->rollback if $oldAutoCommit;
 174     return $error if $error;
 175   }
 176
 177   if ( $new->svcpart != $old->svcpart ) {
 178     my $svc_x = $new->svc_x;
 179     my $new_svc_x = ref($svc_x)->new({$svc_x->hash});
 180     my $error = $new_svc_x->replace($svc_x);
 181     if ( $error ) {
 182       $dbh->rollback if $oldAutoCommit;
 183       return $error if $error;
 184     }
 185   }
 186
 187   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 188   ''; #no error
 189
 190 }
 191
 192 =item check
 193
 194 Checks all fields to make sure this is a valid service.  If there is an error,
 195 returns the error, otehrwise returns false.  Called by the insert and
 196 replace methods.
 197
 198 =cut
 199
 200 sub check {
 201   my $self = shift;
 202
 203   my $error =
 204     $self->ut_numbern('svcnum')
 205     || $self->ut_numbern('pkgnum')
 206     || $self->ut_number('svcpart')
 207   ;
 208   return $error if $error;
 209
 210   my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } );
 211   return "Unknown svcpart" unless $part_svc;
 212
 213   if ( $self->pkgnum ) {
 214     my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
 215     return "Unknown pkgnum" unless $cust_pkg;
 216     my $pkg_svc = qsearchs( 'pkg_svc', {
 217       'pkgpart' => $cust_pkg->pkgpart,
 218       'svcpart' => $self->svcpart,
 219     });
 220     # or new FS::pkg_svc ( { 'pkgpart'  => $cust_pkg->pkgpart,
 221     #                        'svcpart'  => $self->svcpart,
 222     #                        'quantity' => 0                   } );
 223     my $quantity = $pkg_svc ? $pkg_svc->quantity : 0;
 224
 225     my @cust_svc = qsearch('cust_svc', {
 226       'pkgnum'  => $self->pkgnum,
 227       'svcpart' => $self->svcpart,
 228     });
 229     return "Already ". scalar(@cust_svc). " ". $part_svc->svc.
 230            " services for pkgnum ". $self->pkgnum
 231       if scalar(@cust_svc) >= $quantity;
 232   }
 233
 234   ''; #no error
 235 }
 236
 237 =item part_svc
 238
 239 Returns the definition for this service, as a FS::part_svc object (see
 240 L<FS::part_svc>).
 241
 242 =cut
 243
 244 sub part_svc {
 245   my $self = shift;
 246   $self->{'_svcpart'}
 247     ? $self->{'_svcpart'}
 248     : qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } );
 249 }
 250
 251 =item cust_pkg
 252
 253 Returns the definition for this service, as a FS::part_svc object (see
 254 L<FS::part_svc>).
 255
 256 =cut
 257
 258 sub cust_pkg {
 259   my $self = shift;
 260   qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
 261 }
 262
 263 =item label
 264
 265 Returns a list consisting of:
 266 - The name of this service (from part_svc)
 267 - A meaningful identifier (username, domain, or mail alias)
 268 - The table name (i.e. svc_domain) for this service
 269
 270 =cut
 271
 272 sub label {
 273   my $self = shift;
 274   my $svcdb = $self->part_svc->svcdb;
 275   my $svc_x = $self->svc_x
 276     or die "can't find $svcdb.svcnum ". $self->svcnum;
 277   my $tag;
 278   if ( $svcdb eq 'svc_acct' ) {
 279     $tag = $svc_x->email;
 280   } elsif ( $svcdb eq 'svc_forward' ) {
 281     my $svc_acct = qsearchs( 'svc_acct', { 'svcnum' => $svc_x->srcsvc } );
 282     $tag = $svc_acct->email. '->';
 283     if ( $svc_x->dstsvc ) {
 284       $svc_acct = qsearchs( 'svc_acct', { 'svcnum' => $svc_x->dstsvc } );
 285       $tag .= $svc_acct->email;
 286     } else {
 287       $tag .= $svc_x->dst;
 288     }
 289   } elsif ( $svcdb eq 'svc_domain' ) {
 290     $tag = $svc_x->getfield('domain');
 291   } elsif ( $svcdb eq 'svc_www' ) {
 292     my $domain = qsearchs( 'domain_record', { 'recnum' => $svc_x->recnum } );
 293     $tag = $domain->reczone;
 294   } elsif ( $svcdb eq 'svc_broadband' ) {
 295     $tag = $svc_x->ip_addr . '/' . $svc_x->ip_netmask;
 296   } else {
 297     cluck "warning: asked for label of unsupported svcdb; using svcnum";
 298     $tag = $svc_x->getfield('svcnum');
 299   }
 300   $self->part_svc->svc, $tag, $svcdb;
 301 }
 302
 303 =item svc_x
 304
 305 Returns the FS::svc_XXX object for this service (i.e. an FS::svc_acct object or
 306 FS::svc_domain object, etc.)
 307
 308 =cut
 309
 310 sub svc_x {
 311   my $self = shift;
 312   my $svcdb = $self->part_svc->svcdb;
 313   if ( $svcdb eq 'svc_acct' && $self->{'_svc_acct'} ) {
 314     $self->{'_svc_acct'};
 315   } else {
 316     qsearchs( $svcdb, { 'svcnum' => $self->svcnum } );
 317   }
 318 }
 319
 320 =item seconds_since TIMESTAMP
 321
 322 See L<FS::svc_acct/seconds_since>.  Equivalent to
 323 $cust_svc->svc_x->seconds_since, but more efficient.  Meaningless for records
 324 where B<svcdb> is not "svc_acct".
 325
 326 =cut
 327
 328 #note: implementation here, POD in FS::svc_acct
 329 sub seconds_since {
 330   my($self, $since) = @_;
 331   my $dbh = dbh;
 332   my $sth = $dbh->prepare(' SELECT SUM(logout-login) FROM session
 333                               WHERE svcnum = ?
 334                                 AND login >= ?
 335                                 AND logout IS NOT NULL'
 336   ) or die $dbh->errstr;
 337   $sth->execute($self->svcnum, $since) or die $sth->errstr;
 338   $sth->fetchrow_arrayref->[0];
 339 }
 340
 341 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 342
 343 See L<FS::svc_acct/seconds_since_sqlradacct>.  Equivalent to
 344 $cust_svc->svc_x->seconds_since_sqlradacct, but more efficient.  Meaningless
 345 for records where B<svcdb> is not "svc_acct".
 346
 347 =cut
 348
 349 #note: implementation here, POD in FS::svc_acct
 350 sub seconds_since_sqlradacct {
 351   my($self, $start, $end) = @_;
 352
 353   my $username = $self->svc_x->username;
 354
 355   my @part_export = $self->part_svc->part_export('sqlradius')
 356     or die "no sqlradius export configured for this service type";
 357     #or return undef;
 358
 359   my $seconds = 0;
 360   foreach my $part_export ( @part_export ) {
 361
 362     my $dbh = DBI->connect( map { $part_export->option($_) }
 363                             qw(datasrc username password)    )
 364       or die "can't connect to sqlradius database: ". $DBI::errstr;
 365
 366     #select a unix time conversion function based on database type
 367     my $str2time;
 368     if ( $dbh->{Driver}->{Name} eq 'mysql' ) {
 369       $str2time = 'UNIX_TIMESTAMP(';
 370     } elsif ( $dbh->{Driver}->{Name} eq 'Pg' ) {
 371       $str2time = 'EXTRACT( EPOCH FROM ';
 372     } else {
 373       warn "warning: unknown database type ". $dbh->{Driver}->{Name}.
 374            "; guessing how to convert to UNIX timestamps";
 375       $str2time = 'extract(epoch from ';
 376     }
 377
 378     my $query;
 379
 380     #find closed sessions completely within the given range
 381     my $sth = $dbh->prepare("SELECT SUM(acctsessiontime)
 382                                FROM radacct
 383                                WHERE UserName = ?
 384                                  AND $str2time AcctStartTime) >= ?
 385                                  AND $str2time AcctStopTime ) <  ?
 386                                  AND $str2time AcctStopTime ) > 0
 387                                  AND AcctStopTime IS NOT NULL"
 388     ) or die $dbh->errstr;
 389     $sth->execute($username, $start, $end) or die $sth->errstr;
 390     my $regular = $sth->fetchrow_arrayref->[0];
 391
 392     #find open sessions which start in the range, count session start->range end
 393     $query = "SELECT SUM( ? - $str2time AcctStartTime ) )
 394                 FROM radacct
 395                 WHERE UserName = ?
 396                   AND $str2time AcctStartTime ) >= ?
 397                   AND $str2time AcctStartTime ) <  ?
 398                   AND ( ? - $str2time AcctStartTime ) ) < 86400
 399                   AND (    $str2time AcctStopTime ) = 0
 400                                     OR AcctStopTime IS NULL )";
 401     $sth = $dbh->prepare($query) or die $dbh->errstr;
 402     $sth->execute($end, $username, $start, $end, $end)
 403       or die $sth->errstr. " executing query $query";
 404     my $start_during = $sth->fetchrow_arrayref->[0];
 405
 406     #find closed sessions which start before the range but stop during,
 407     #count range start->session end
 408     $sth = $dbh->prepare("SELECT SUM( $str2time AcctStopTime ) - ? )
 409                             FROM radacct
 410                             WHERE UserName = ?
 411                               AND $str2time AcctStartTime ) < ?
 412                               AND $str2time AcctStopTime  ) >= ?
 413                               AND $str2time AcctStopTime  ) <  ?
 414                               AND $str2time AcctStopTime ) > 0
 415                               AND AcctStopTime IS NOT NULL"
 416     ) or die $dbh->errstr;
 417     $sth->execute($start, $username, $start, $start, $end ) or die $sth->errstr;
 418     my $end_during = $sth->fetchrow_arrayref->[0];
 419
 420     #find closed (not anymore - or open) sessions which start before the range
 421     # but stop after, or are still open, count range start->range end
 422     # don't count open sessions (probably missing stop record)
 423     $sth = $dbh->prepare("SELECT COUNT(*)
 424                             FROM radacct
 425                             WHERE UserName = ?
 426                               AND $str2time AcctStartTime ) < ?
 427                               AND ( $str2time AcctStopTime ) >= ?
 428                                                                   )"
 429                               #      OR AcctStopTime =  0
 430                               #      OR AcctStopTime IS NULL       )"
 431     ) or die $dbh->errstr;
 432     $sth->execute($username, $start, $end ) or die $sth->errstr;
 433     my $entire_range = ($end-$start) * $sth->fetchrow_arrayref->[0];
 434
 435     $seconds += $regular + $end_during + $start_during + $entire_range;
 436
 437   }
 438
 439   $seconds;
 440
 441 }
 442
 443 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 444
 445 See L<FS::svc_acct/attribute_since_sqlradacct>.  Equivalent to
 446 $cust_svc->svc_x->attribute_since_sqlradacct, but more efficient.  Meaningless
 447 for records where B<svcdb> is not "svc_acct".
 448
 449 =cut
 450
 451 #note: implementation here, POD in FS::svc_acct
 452 #(false laziness w/seconds_since_sqlradacct above)
 453 sub attribute_since_sqlradacct {
 454   my($self, $start, $end, $attrib) = @_;
 455
 456   my $username = $self->svc_x->username;
 457
 458   my @part_export = $self->part_svc->part_export('sqlradius')
 459     or die "no sqlradius export configured for this service type";
 460     #or return undef;
 461
 462   my $sum = 0;
 463
 464   foreach my $part_export ( @part_export ) {
 465
 466     my $dbh = DBI->connect( map { $part_export->option($_) }
 467                             qw(datasrc username password)    )
 468       or die "can't connect to sqlradius database: ". $DBI::errstr;
 469
 470     #select a unix time conversion function based on database type
 471     my $str2time;
 472     if ( $dbh->{Driver}->{Name} eq 'mysql' ) {
 473       $str2time = 'UNIX_TIMESTAMP(';
 474     } elsif ( $dbh->{Driver}->{Name} eq 'Pg' ) {
 475       $str2time = 'EXTRACT( EPOCH FROM ';
 476     } else {
 477       warn "warning: unknown database type ". $dbh->{Driver}->{Name}.
 478            "; guessing how to convert to UNIX timestamps";
 479       $str2time = 'extract(epoch from ';
 480     }
 481
 482     my $sth = $dbh->prepare("SELECT SUM($attrib)
 483                                FROM radacct
 484                                WHERE UserName = ?
 485                                  AND $str2time AcctStopTime ) >= ?
 486                                  AND $str2time AcctStopTime ) <  ?
 487                                  AND AcctStopTime IS NOT NULL"
 488     ) or die $dbh->errstr;
 489     $sth->execute($username, $start, $end) or die $sth->errstr;
 490
 491     $sum += $sth->fetchrow_arrayref->[0];
 492
 493   }
 494
 495   $sum;
 496
 497 }
 498
 499 =back
 500
 501 =head1 BUGS
 502
 503 Behaviour of changing the svcpart of cust_svc records is undefined and should
 504 possibly be prohibited, and pkg_svc records are not checked.
 505
 506 pkg_svc records are not checked in general (here).
 507
 508 Deleting this record doesn't check or delete the svc_* record associated
 509 with this record.
 510
 511 In seconds_since_sqlradacct, specifying a DATASRC/USERNAME/PASSWORD instead of
 512 a DBI database handle is not yet implemented.
 513
 514 =head1 SEE ALSO
 515
 516 L<FS::Record>, L<FS::cust_pkg>, L<FS::part_svc>, L<FS::pkg_svc>,
 517 schema.html from the base documentation
 518
 519 =cut
 520
 521 1;
 522