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