FS/FS/cust_svc.pm

   1 package FS::cust_svc;
   2 use base qw( FS::cust_main_Mixin FS::option_Common ); #FS::Record );
   3
   4 use strict;
   5 use vars qw( $DEBUG $me $ignore_quantity $conf $ticket_system );
   6 use Carp;
   7 #use Scalar::Util qw( blessed );
   8 use List::Util qw( max );
   9 use FS::Conf;
  10 use FS::Record qw( qsearch qsearchs dbh str2time_sql str2time_sql_closing );
  11 use FS::part_pkg;
  12 use FS::part_svc;
  13 use FS::pkg_svc;
  14 use FS::part_svc_link;
  15 use FS::domain_record;
  16 use FS::part_export;
  17 use FS::cdr;
  18 use FS::UI::Web;
  19
  20 #most FS::svc_ classes are autoloaded in svc_x emthod
  21 use FS::svc_acct;  #this one is used in the cache stuff
  22
  23
  24 $DEBUG = 0;
  25 $me = '[cust_svc]';
  26
  27 $ignore_quantity = 0;
  28
  29 #ask FS::UID to run this stuff for us later
  30 FS::UID->install_callback( sub {
  31   $conf = new FS::Conf;
  32   $ticket_system = $conf->config('ticket_system')
  33 });
  34
  35 sub _cache {
  36   my $self = shift;
  37   my ( $hashref, $cache ) = @_;
  38   if ( $hashref->{'username'} ) {
  39     $self->{'_svc_acct'} = FS::svc_acct->new($hashref, '');
  40   }
  41   if ( $hashref->{'svc'} ) {
  42     $self->{'_svcpart'} = FS::part_svc->new($hashref);
  43   }
  44 }
  45
  46 =head1 NAME
  47
  48 FS::cust_svc - Object method for cust_svc objects
  49
  50 =head1 SYNOPSIS
  51
  52   use FS::cust_svc;
  53
  54   $record = new FS::cust_svc \%hash
  55   $record = new FS::cust_svc { 'column' => 'value' };
  56
  57   $error = $record->insert;
  58
  59   $error = $new_record->replace($old_record);
  60
  61   $error = $record->delete;
  62
  63   $error = $record->check;
  64
  65   ($label, $value) = $record->label;
  66
  67 =head1 DESCRIPTION
  68
  69 An FS::cust_svc represents a service.  FS::cust_svc inherits from FS::Record.
  70 The following fields are currently supported:
  71
  72 =over 4
  73
  74 =item svcnum - primary key (assigned automatically for new services)
  75
  76 =item pkgnum - Package (see L<FS::cust_pkg>)
  77
  78 =item svcpart - Service definition (see L<FS::part_svc>)
  79
  80 =item agent_svcid - Optional legacy service ID
  81
  82 =item overlimit - date the service exceeded its usage limit
  83
  84 =back
  85
  86 =head1 METHODS
  87
  88 =over 4
  89
  90 =item new HASHREF
  91
  92 Creates a new service.  To add the refund to the database, see L<"insert">.
  93 Services are normally created by creating FS::svc_ objects (see
  94 L<FS::svc_acct>, L<FS::svc_domain>, and L<FS::svc_forward>, among others).
  95
  96 =cut
  97
  98 sub table { 'cust_svc'; }
  99
 100 =item insert
 101
 102 Adds this service to the database.  If there is an error, returns the error,
 103 otherwise returns false.
 104
 105 =item delete
 106
 107 Deletes this service from the database.  If there is an error, returns the
 108 error, otherwise returns false.  Note that this only removes the cust_svc
 109 record - you should probably use the B<cancel> method instead.
 110
 111 =cut
 112
 113 my $rt_session;
 114
 115 sub delete {
 116   my $self = shift;
 117
 118   my $cust_pkg = $self->cust_pkg;
 119   my $custnum = $cust_pkg->custnum if $cust_pkg;
 120
 121   my $error = $self->SUPER::delete;
 122   return $error if $error;
 123
 124   if ( $ticket_system eq 'RT_Internal' ) {
 125     unless ( $rt_session ) {
 126       FS::TicketSystem->init;
 127       $rt_session = FS::TicketSystem->session;
 128     }
 129     my $links = RT::Links->new($rt_session->{CurrentUser});
 130     my $svcnum = $self->svcnum;
 131     $links->Limit(FIELD => 'Target',
 132                   VALUE => 'freeside://freeside/cust_svc/'.$svcnum);
 133     while ( my $l = $links->Next ) {
 134       my ($val, $msg);
 135       if ( $custnum ) {
 136         # re-link to point to the customer instead
 137         ($val, $msg) =
 138           $l->SetTarget('freeside://freeside/cust_main/'.$custnum);
 139       } else {
 140         # unlinked service
 141         ($val, $msg) = $l->Delete;
 142       }
 143       # can't do anything useful on error
 144       warn "error unlinking ticket $svcnum: $msg\n" if !$val;
 145     }
 146   }
 147 }
 148
 149 =item cancel
 150
 151 Cancels the relevant service by calling the B<cancel> method of the associated
 152 FS::svc_XXX object (i.e. an FS::svc_acct object or FS::svc_domain object),
 153 deleting the FS::svc_XXX record and then deleting this record.
 154
 155 If there is an error, returns the error, otherwise returns false.
 156
 157 =cut
 158
 159 sub cancel {
 160   my($self,%opt) = @_;
 161
 162   local $SIG{HUP} = 'IGNORE';
 163   local $SIG{INT} = 'IGNORE';
 164   local $SIG{QUIT} = 'IGNORE';
 165   local $SIG{TERM} = 'IGNORE';
 166   local $SIG{TSTP} = 'IGNORE';
 167   local $SIG{PIPE} = 'IGNORE';
 168
 169   my $oldAutoCommit = $FS::UID::AutoCommit;
 170   local $FS::UID::AutoCommit = 0;
 171   my $dbh = dbh;
 172
 173   my $part_svc = $self->part_svc;
 174
 175   $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 176     $dbh->rollback if $oldAutoCommit;
 177     return "Illegal svcdb value in part_svc!";
 178   };
 179   my $svcdb = $1;
 180   require "FS/$svcdb.pm";
 181
 182   my $svc = $self->svc_x;
 183   if ($svc) {
 184     if ( %opt && $opt{'date'} ) {
 185         my $error = $svc->expire($opt{'date'});
 186         if ( $error ) {
 187           $dbh->rollback if $oldAutoCommit;
 188           return "Error expiring service: $error";
 189         }
 190     } else {
 191         my $error = $svc->cancel;
 192         if ( $error ) {
 193           $dbh->rollback if $oldAutoCommit;
 194           return "Error canceling service: $error";
 195         }
 196         $error = $svc->delete; #this deletes this cust_svc record as well
 197         if ( $error ) {
 198           $dbh->rollback if $oldAutoCommit;
 199           return "Error deleting service: $error";
 200         }
 201     }
 202
 203   } elsif ( !%opt ) {
 204
 205     #huh?
 206     warn "WARNING: no svc_ record found for svcnum ". $self->svcnum.
 207          "; deleting cust_svc only\n";
 208
 209     my $error = $self->delete;
 210     if ( $error ) {
 211       $dbh->rollback if $oldAutoCommit;
 212       return "Error deleting cust_svc: $error";
 213     }
 214
 215   }
 216
 217   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 218
 219   ''; #no errors
 220
 221 }
 222
 223 =item overlimit [ ACTION ]
 224
 225 Retrieves or sets the overlimit date.  If ACTION is absent, return
 226 the present value of overlimit.  If ACTION is present, it can
 227 have the value 'suspend' or 'unsuspend'.  In the case of 'suspend' overlimit
 228 is set to the current time if it is not already set.  The 'unsuspend' value
 229 causes the time to be cleared.
 230
 231 If there is an error on setting, returns the error, otherwise returns false.
 232
 233 =cut
 234
 235 sub overlimit {
 236   my $self = shift;
 237   my $action = shift or return $self->getfield('overlimit');
 238
 239   local $SIG{HUP} = 'IGNORE';
 240   local $SIG{INT} = 'IGNORE';
 241   local $SIG{QUIT} = 'IGNORE';
 242   local $SIG{TERM} = 'IGNORE';
 243   local $SIG{TSTP} = 'IGNORE';
 244   local $SIG{PIPE} = 'IGNORE';
 245
 246   my $oldAutoCommit = $FS::UID::AutoCommit;
 247   local $FS::UID::AutoCommit = 0;
 248   my $dbh = dbh;
 249
 250   if ( $action eq 'suspend' ) {
 251     $self->setfield('overlimit', time) unless $self->getfield('overlimit');
 252   }elsif ( $action eq 'unsuspend' ) {
 253     $self->setfield('overlimit', '');
 254   }else{
 255     die "unexpected action value: $action";
 256   }
 257
 258   local $ignore_quantity = 1;
 259   my $error = $self->replace;
 260   if ( $error ) {
 261     $dbh->rollback if $oldAutoCommit;
 262     return "Error setting overlimit: $error";
 263   }
 264
 265   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 266
 267   ''; #no errors
 268
 269 }
 270
 271 =item replace OLD_RECORD
 272
 273 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 274 returns the error, otherwise returns false.
 275
 276 =cut
 277
 278 sub replace {
 279 #  my $new = shift;
 280 #
 281 #  my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 282 #              ? shift
 283 #              : $new->replace_old;
 284   my ( $new, $old ) = ( shift, shift );
 285   $old = $new->replace_old unless defined($old);
 286
 287   local $SIG{HUP} = 'IGNORE';
 288   local $SIG{INT} = 'IGNORE';
 289   local $SIG{QUIT} = 'IGNORE';
 290   local $SIG{TERM} = 'IGNORE';
 291   local $SIG{TSTP} = 'IGNORE';
 292   local $SIG{PIPE} = 'IGNORE';
 293
 294   my $oldAutoCommit = $FS::UID::AutoCommit;
 295   local $FS::UID::AutoCommit = 0;
 296   my $dbh = dbh;
 297
 298   if ( $new->svcpart != $old->svcpart ) {
 299     my $svc_x = $new->svc_x;
 300     my $new_svc_x = ref($svc_x)->new({$svc_x->hash, svcpart=>$new->svcpart });
 301     local($FS::Record::nowarn_identical) = 1;
 302     my $error = $new_svc_x->replace($svc_x);
 303     if ( $error ) {
 304       $dbh->rollback if $oldAutoCommit;
 305       return $error if $error;
 306     }
 307   }
 308
 309 #  #trigger a re-export on pkgnum changes?
 310 #  # (of prepaid packages), for Expiration RADIUS attribute
 311 #  if ( $new->pkgnum != $old->pkgnum && $new->cust_pkg->part_pkg->is_prepaid ) {
 312 #    my $svc_x = $new->svc_x;
 313 #    local($FS::Record::nowarn_identical) = 1;
 314 #    my $error = $svc_x->export('replace');
 315 #    if ( $error ) {
 316 #      $dbh->rollback if $oldAutoCommit;
 317 #      return $error if $error;
 318 #    }
 319 #  }
 320
 321   #trigger a pkg_change export on pkgnum changes
 322   if ( $new->pkgnum != $old->pkgnum ) {
 323     my $error = $new->svc_x->export('pkg_change', $new->cust_pkg,
 324                                                   $old->cust_pkg,
 325                                    );
 326
 327     if ( $error ) {
 328       $dbh->rollback if $oldAutoCommit;
 329       return $error if $error;
 330     }
 331   } # if pkgnum is changing
 332
 333   #my $error = $new->SUPER::replace($old, @_);
 334   my $error = $new->SUPER::replace($old);
 335
 336   #trigger a relocate export on location changes
 337   if ( $new->cust_pkg->locationnum != $old->cust_pkg->locationnum ) {
 338     my $svc_x = $new->svc_x;
 339     if ( $svc_x->locationnum ) {
 340       if ( $svc_x->locationnum == $old->cust_pkg->locationnum ) {
 341         # in this case, set the service location to be the same as the new
 342         # package location
 343         $svc_x->set('locationnum', $new->cust_pkg->locationnum);
 344         # and replace it, which triggers a relocate export so we don't
 345         # need to
 346         $error ||= $svc_x->replace;
 347       } else {
 348         # the service already has a different location from its package
 349         # so don't change it
 350       }
 351     } else {
 352       # the service doesn't have a locationnum (either isn't of a type
 353       # that has the locationnum field, or the locationnum is null and
 354       # defaults to cust_pkg->locationnum)
 355       # so just trigger the export here
 356       $error ||= $new->svc_x->export('relocate',
 357                                      $new->cust_pkg->cust_location,
 358                                      $old->cust_pkg->cust_location,
 359                                   );
 360     } # if ($svc_x->locationnum)
 361   } # if this is a location change
 362
 363   if ( $error ) {
 364     $dbh->rollback if $oldAutoCommit;
 365     return $error if $error
 366   }
 367
 368   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 369   ''; #no error
 370
 371 }
 372
 373 =item check
 374
 375 Checks all fields to make sure this is a valid service.  If there is an error,
 376 returns the error, otherwise returns false.  Called by the insert and
 377 replace methods.
 378
 379 =cut
 380
 381 sub check {
 382   my $self = shift;
 383
 384   my $error =
 385     $self->ut_numbern('svcnum')
 386     || $self->ut_numbern('pkgnum')
 387     || $self->ut_number('svcpart')
 388     || $self->ut_numbern('agent_svcid')
 389     || $self->ut_numbern('overlimit')
 390   ;
 391   return $error if $error;
 392
 393   my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } );
 394   return "Unknown svcpart" unless $part_svc;
 395
 396   if ( $self->pkgnum && ! $ignore_quantity ) {
 397
 398     #slightly inefficient since ->pkg_svc will also look it up, but fixing
 399     # a much larger perf problem and have bigger fish to fry
 400     my $cust_pkg = $self->cust_pkg;
 401
 402     my $pkg_svc = $self->pkg_svc
 403                     || new FS::pkg_svc { 'svcpart'  => $self->svcpart,
 404                                          'pkgpart'  => $cust_pkg->pkgpart,
 405                                          'quantity' => 0,
 406                                        };
 407
 408     #service add-ons, kinda false laziness/reimplementation of part_pkg->pkg_svc
 409     foreach my $part_pkg_link ( $cust_pkg->part_pkg->svc_part_pkg_link ) {
 410       my $addon_pkg_svc = qsearchs('pkg_svc', {
 411                             pkgpart => $part_pkg_link->dst_pkgpart,
 412                             svcpart => $self->svcpart,
 413                           });
 414       $pkg_svc->quantity( $pkg_svc->quantity + $addon_pkg_svc->quantity )
 415         if $addon_pkg_svc;
 416     }
 417
 418    #better error message?  UI shouldn't get here
 419    return "No svcpart ". $self->svcpart.
 420           " services in pkgpart ". $cust_pkg->pkgpart
 421      unless $pkg_svc->quantity > 0;
 422
 423     my $num_cust_svc = $cust_pkg->num_cust_svc( $self->svcpart );
 424
 425     #false laziness w/cust_pkg->part_svc
 426     my $num_avail = max( 0, ($cust_pkg->quantity || 1) * $pkg_svc->quantity
 427                             - $num_cust_svc
 428                        );
 429
 430    #better error message?  again, UI shouldn't get here
 431     return "Already $num_cust_svc ". $pkg_svc->part_svc->svc.
 432            " services for pkgnum ". $self->pkgnum
 433       if $num_avail <= 0;
 434
 435     #part_svc_link rules (only make sense in pkgpart context, and
 436     # skipping this when ignore_quantity is set DTRT when we're "forcing"
 437     # an implicit change here (location change triggered pkgpart change,
 438     # ->overlimit, bulk customer service changes)
 439     foreach my $part_svc_link ( $self->part_svc_link(
 440                                   link_type   => 'cust_svc_provision_restrict',
 441                                 )
 442     ) {
 443       return $part_svc_link->dst_svc. ' must be provisioned before '.
 444              $part_svc_link->src_svc
 445         unless qsearchs({
 446           'table'    => 'cust_svc',
 447           'hashref'  => { 'pkgnum'  => $self->pkgnum,
 448                           'svcpart' => $part_svc_link->dst_svcpart,
 449                         },
 450           'order_by' => 'LIMIT 1',
 451         });
 452     }
 453
 454   }
 455
 456   $self->SUPER::check;
 457 }
 458
 459 =item part_svc_link
 460
 461 Returns the service dependencies (see L<FS::part_svc_link>) for the given
 462 search options, taking into account this service definition as source and
 463 this customer's agent.
 464
 465 Available options are any field in part_svc_link.  Typically used options are
 466 link_type.
 467
 468 =cut
 469
 470 sub part_svc_link {
 471   my $self = shift;
 472   my $agentnum = $self->pkgnum ? $self->cust_pkg->cust_main->agentnum : '';
 473   FS::part_svc_link->by_agentnum($agentnum, src_svcpart=>$self->svcpart, @_);
 474 }
 475
 476 =item display_svcnum
 477
 478 Returns the displayed service number for this service: agent_svcid if it has a
 479 value, svcnum otherwise
 480
 481 =cut
 482
 483 sub display_svcnum {
 484   my $self = shift;
 485   $self->agent_svcid || $self->svcnum;
 486 }
 487
 488 =item part_svc
 489
 490 Returns the definition for this service, as a FS::part_svc object (see
 491 L<FS::part_svc>).
 492
 493 =cut
 494
 495 sub part_svc {
 496   my $self = shift;
 497   $self->{'_svcpart'}
 498     ? $self->{'_svcpart'}
 499     : qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } );
 500 }
 501
 502 =item cust_pkg
 503
 504 Returns the package this service belongs to, as a FS::cust_pkg object (see
 505 L<FS::cust_pkg>).
 506
 507 =item pkg_svc
 508
 509 Returns the pkg_svc record for for this service, if applicable.
 510
 511 =cut
 512
 513 sub pkg_svc {
 514   my $self = shift;
 515   my $cust_pkg = $self->cust_pkg;
 516   return undef unless $cust_pkg;
 517
 518   qsearchs( 'pkg_svc', { 'svcpart' => $self->svcpart,
 519                          'pkgpart' => $cust_pkg->pkgpart,
 520                        }
 521           );
 522 }
 523
 524 =item date_inserted
 525
 526 Returns the date this service was inserted.
 527
 528 =cut
 529
 530 sub date_inserted {
 531   my $self = shift;
 532   $self->h_date('insert');
 533 }
 534
 535 =item pkg_cancel_date
 536
 537 Returns the date this service's package was canceled.  This normally only
 538 exists for a service that's been preserved through cancellation with the
 539 part_pkg.preserve flag.
 540
 541 =cut
 542
 543 sub pkg_cancel_date {
 544   my $self = shift;
 545   my $cust_pkg = $self->cust_pkg or return;
 546   return $cust_pkg->getfield('cancel') || '';
 547 }
 548
 549 =item label
 550
 551 Returns a list consisting of:
 552 - The name of this service (from part_svc)
 553 - A meaningful identifier (username, domain, or mail alias)
 554 - The table name (i.e. svc_domain) for this service
 555 - svcnum
 556
 557 Usage example:
 558
 559   my($label, $value, $svcdb) = $cust_svc->label;
 560
 561 =item label_long
 562
 563 Like the B<label> method, except the second item in the list ("meaningful
 564 identifier") may be longer - typically, a full name is included.
 565
 566 =cut
 567
 568 sub label      { shift->_label('svc_label',      @_); }
 569 sub label_long { shift->_label('svc_label_long', @_); }
 570
 571 sub _label {
 572   my $self = shift;
 573   my $method = shift;
 574   my $svc_x = $self->svc_x
 575     or return "can't find ". $self->part_svc->svcdb. '.svcnum '. $self->svcnum;
 576
 577   $self->$method($svc_x);
 578 }
 579
 580 sub svc_label      { shift->_svc_label('label',      @_); }
 581 sub svc_label_long { shift->_svc_label('label_long', @_); }
 582
 583 sub _svc_label {
 584   my( $self, $method, $svc_x ) = ( shift, shift, shift );
 585
 586   (
 587     $self->part_svc->svc,
 588     $svc_x->$method(@_),
 589     $self->part_svc->svcdb,
 590     $self->svcnum
 591   );
 592
 593 }
 594
 595 =item export_links
 596
 597 Returns a listref of html elements associated with this service's exports.
 598
 599 =cut
 600
 601 sub export_links {
 602   my $self = shift;
 603   my $svc_x = $self->svc_x
 604     or return [ "can't find ". $self->part_svc->svcdb. '.svcnum '. $self->svcnum ];
 605
 606   $svc_x->export_links;
 607 }
 608
 609 =item export_getsettings
 610
 611 Returns two hashrefs of settings associated with this service's exports.
 612
 613 =cut
 614
 615 sub export_getsettings {
 616   my $self = shift;
 617   my $svc_x = $self->svc_x
 618     or return "can't find ". $self->part_svc->svcdb. '.svcnum '. $self->svcnum;
 619
 620   $svc_x->export_getsettings;
 621 }
 622
 623
 624 =item svc_x
 625
 626 Returns the FS::svc_XXX object for this service (i.e. an FS::svc_acct object or
 627 FS::svc_domain object, etc.)
 628
 629 =cut
 630
 631 sub svc_x {
 632   my $self = shift;
 633   my $svcdb = $self->part_svc->svcdb;
 634   if ( $svcdb eq 'svc_acct' && $self->{'_svc_acct'} ) {
 635     $self->{'_svc_acct'};
 636   } else {
 637     require "FS/$svcdb.pm";
 638     warn "$me svc_x: part_svc.svcpart ". $self->part_svc->svcpart.
 639          ", so searching for $svcdb.svcnum ". $self->svcnum. "\n"
 640       if $DEBUG;
 641     qsearchs( $svcdb, { 'svcnum' => $self->svcnum } );
 642   }
 643 }
 644
 645 =item seconds_since TIMESTAMP
 646
 647 See L<FS::svc_acct/seconds_since>.  Equivalent to
 648 $cust_svc->svc_x->seconds_since, but more efficient.  Meaningless for records
 649 where B<svcdb> is not "svc_acct".
 650
 651 =cut
 652
 653 #internal session db deprecated (or at least on hold)
 654 sub seconds_since { 'internal session db deprecated'; };
 655 ##note: implementation here, POD in FS::svc_acct
 656 #sub seconds_since {
 657 #  my($self, $since) = @_;
 658 #  my $dbh = dbh;
 659 #  my $sth = $dbh->prepare(' SELECT SUM(logout-login) FROM session
 660 #                              WHERE svcnum = ?
 661 #                                AND login >= ?
 662 #                                AND logout IS NOT NULL'
 663 #  ) or die $dbh->errstr;
 664 #  $sth->execute($self->svcnum, $since) or die $sth->errstr;
 665 #  $sth->fetchrow_arrayref->[0];
 666 #}
 667
 668 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 669
 670 See L<FS::svc_acct/seconds_since_sqlradacct>.  Equivalent to
 671 $cust_svc->svc_x->seconds_since_sqlradacct, but more efficient.  Meaningless
 672 for records where B<svcdb> is not "svc_acct".
 673
 674 =cut
 675
 676 #note: implementation here, POD in FS::svc_acct
 677 sub seconds_since_sqlradacct {
 678   my($self, $start, $end) = @_;
 679
 680   my $mes = "$me seconds_since_sqlradacct:";
 681
 682   my $svc_x = $self->svc_x;
 683
 684   my @part_export = $self->part_svc->part_export_usage;
 685   die "no accounting-capable exports are enabled for ". $self->part_svc->svc.
 686       " service definition"
 687     unless @part_export;
 688     #or return undef;
 689
 690   my $seconds = 0;
 691   foreach my $part_export ( @part_export ) {
 692
 693     next if $part_export->option('ignore_accounting');
 694
 695     warn "$mes connecting to sqlradius database\n"
 696       if $DEBUG;
 697
 698     my $dbh = DBI->connect( map { $part_export->option($_) }
 699                             qw(datasrc username password)    )
 700       or die "can't connect to sqlradius database: ". $DBI::errstr;
 701
 702     warn "$mes connected to sqlradius database\n"
 703       if $DEBUG;
 704
 705     #select a unix time conversion function based on database type
 706     my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
 707     my $closing = str2time_sql_closing( $dbh->{Driver}->{Name} );
 708
 709     my $username = $part_export->export_username($svc_x);
 710
 711     my $query;
 712
 713     warn "$mes finding closed sessions completely within the given range\n"
 714       if $DEBUG;
 715
 716     my $realm = '';
 717     my $realmparam = '';
 718     if ($part_export->option('process_single_realm')) {
 719       $realm = 'AND Realm = ?';
 720       $realmparam = $part_export->option('realm');
 721     }
 722
 723     my $sth = $dbh->prepare("SELECT SUM(acctsessiontime)
 724                                FROM radacct
 725                                WHERE UserName = ?
 726                                  $realm
 727                                  AND $str2time AcctStartTime $closing >= ?
 728                                  AND $str2time AcctStopTime  $closing <  ?
 729                                  AND $str2time AcctStopTime  $closing > 0
 730                                  AND AcctStopTime IS NOT NULL"
 731     ) or die $dbh->errstr;
 732     $sth->execute($username, ($realm ? $realmparam : ()), $start, $end)
 733       or die $sth->errstr;
 734     my $regular = $sth->fetchrow_arrayref->[0];
 735
 736     warn "$mes finding open sessions which start in the range\n"
 737       if $DEBUG;
 738
 739     # count session start->range end
 740     $query = "SELECT SUM( ? - $str2time AcctStartTime $closing )
 741                 FROM radacct
 742                 WHERE UserName = ?
 743                   $realm
 744                   AND $str2time AcctStartTime $closing >= ?
 745                   AND $str2time AcctStartTime $closing <  ?
 746                   AND ( ? - $str2time AcctStartTime $closing ) < 86400
 747                   AND (    $str2time AcctStopTime $closing = 0
 748                                     OR AcctStopTime IS NULL )";
 749     $sth = $dbh->prepare($query) or die $dbh->errstr;
 750     $sth->execute( $end,
 751                    $username,
 752                    ($realm ? $realmparam : ()),
 753                    $start,
 754                    $end,
 755                    $end )
 756       or die $sth->errstr. " executing query $query";
 757     my $start_during = $sth->fetchrow_arrayref->[0];
 758
 759     warn "$mes finding closed sessions which start before the range but stop during\n"
 760       if $DEBUG;
 761
 762     #count range start->session end
 763     $sth = $dbh->prepare("SELECT SUM( $str2time AcctStopTime $closing - ? )
 764                             FROM radacct
 765                             WHERE UserName = ?
 766                               $realm
 767                               AND $str2time AcctStartTime $closing < ?
 768                               AND $str2time AcctStopTime  $closing >= ?
 769                               AND $str2time AcctStopTime  $closing <  ?
 770                               AND $str2time AcctStopTime  $closing > 0
 771                               AND AcctStopTime IS NOT NULL"
 772     ) or die $dbh->errstr;
 773     $sth->execute( $start,
 774                    $username,
 775                    ($realm ? $realmparam : ()),
 776                    $start,
 777                    $start,
 778                    $end )
 779       or die $sth->errstr;
 780     my $end_during = $sth->fetchrow_arrayref->[0];
 781
 782     warn "$mes finding closed sessions which start before the range but stop after\n"
 783       if $DEBUG;
 784
 785     # count range start->range end
 786     # don't count open sessions anymore (probably missing stop record)
 787     $sth = $dbh->prepare("SELECT COUNT(*)
 788                             FROM radacct
 789                             WHERE UserName = ?
 790                               $realm
 791                               AND $str2time AcctStartTime $closing < ?
 792                               AND ( $str2time AcctStopTime $closing >= ?
 793                                                                   )"
 794                               #      OR AcctStopTime =  0
 795                               #      OR AcctStopTime IS NULL       )"
 796     ) or die $dbh->errstr;
 797     $sth->execute($username, ($realm ? $realmparam : ()), $start, $end )
 798       or die $sth->errstr;
 799     my $entire_range = ($end-$start) * $sth->fetchrow_arrayref->[0];
 800
 801     $seconds += $regular + $end_during + $start_during + $entire_range;
 802
 803     warn "$mes done finding sessions\n"
 804       if $DEBUG;
 805
 806   }
 807
 808   $seconds;
 809
 810 }
 811
 812 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 813
 814 See L<FS::svc_acct/attribute_since_sqlradacct>.  Equivalent to
 815 $cust_svc->svc_x->attribute_since_sqlradacct, but more efficient.  Meaningless
 816 for records where B<svcdb> is not "svc_acct".
 817
 818 =cut
 819
 820 #note: implementation here, POD in FS::svc_acct
 821 #(false laziness w/seconds_since_sqlradacct above)
 822 sub attribute_since_sqlradacct {
 823   my($self, $start, $end, $attrib) = @_;
 824
 825   my $mes = "$me attribute_since_sqlradacct:";
 826
 827   my $svc_x = $self->svc_x;
 828
 829   my @part_export = $self->part_svc->part_export_usage;
 830   die "no accounting-capable exports are enabled for ". $self->part_svc->svc.
 831       " service definition"
 832     unless @part_export;
 833     #or return undef;
 834
 835   my $sum = 0;
 836
 837   foreach my $part_export ( @part_export ) {
 838
 839     next if $part_export->option('ignore_accounting');
 840
 841     warn "$mes connecting to sqlradius database\n"
 842       if $DEBUG;
 843
 844     my $dbh = DBI->connect( map { $part_export->option($_) }
 845                             qw(datasrc username password)    )
 846       or die "can't connect to sqlradius database: ". $DBI::errstr;
 847
 848     warn "$mes connected to sqlradius database\n"
 849       if $DEBUG;
 850
 851     #select a unix time conversion function based on database type
 852     my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
 853     my $closing = str2time_sql_closing( $dbh->{Driver}->{Name} );
 854
 855     my $username = $part_export->export_username($svc_x);
 856
 857     warn "$mes SUMing $attrib sessions\n"
 858       if $DEBUG;
 859
 860     my $realm = '';
 861     my $realmparam = '';
 862     if ($part_export->option('process_single_realm')) {
 863       $realm = 'AND Realm = ?';
 864       $realmparam = $part_export->option('realm');
 865     }
 866
 867     my $sth = $dbh->prepare("SELECT SUM($attrib)
 868                                FROM radacct
 869                                WHERE UserName = ?
 870                                  $realm
 871                                  AND $str2time AcctStopTime $closing >= ?
 872                                  AND $str2time AcctStopTime $closing <  ?
 873                                  AND AcctStopTime IS NOT NULL"
 874     ) or die $dbh->errstr;
 875     $sth->execute($username, ($realm ? $realmparam : ()), $start, $end)
 876       or die $sth->errstr;
 877
 878     my $row = $sth->fetchrow_arrayref;
 879     $sum += $row->[0] if defined($row->[0]);
 880
 881     warn "$mes done SUMing sessions\n"
 882       if $DEBUG;
 883
 884   }
 885
 886   $sum;
 887
 888 }
 889
 890 #note: implementation here, POD in FS::svc_acct
 891 # false laziness w/above
 892 sub attribute_last_sqlradacct {
 893   my($self, $attrib) = @_;
 894
 895   my $mes = "$me attribute_last_sqlradacct:";
 896
 897   my $svc_x = $self->svc_x;
 898
 899   my @part_export = $self->part_svc->part_export_usage;
 900   die "no accounting-capable exports are enabled for ". $self->part_svc->svc.
 901       " service definition"
 902     unless @part_export;
 903     #or return undef;
 904
 905   my $value = '';
 906   my $AcctStartTime = 0;
 907
 908   foreach my $part_export ( @part_export ) {
 909
 910     next if $part_export->option('ignore_accounting');
 911
 912     warn "$mes connecting to sqlradius database\n"
 913       if $DEBUG;
 914
 915     my $dbh = DBI->connect( map { $part_export->option($_) }
 916                             qw(datasrc username password)    )
 917       or die "can't connect to sqlradius database: ". $DBI::errstr;
 918
 919     warn "$mes connected to sqlradius database\n"
 920       if $DEBUG;
 921
 922     #select a unix time conversion function based on database type
 923     my $str2time = str2time_sql( $dbh->{Driver}->{Name} );
 924     my $closing = str2time_sql_closing( $dbh->{Driver}->{Name} );
 925
 926     my $username = $part_export->export_username($svc_x);
 927
 928     warn "$mes finding most-recent $attrib\n"
 929       if $DEBUG;
 930
 931     my $realm = '';
 932     my $realmparam = '';
 933     if ($part_export->option('process_single_realm')) {
 934       $realm = 'AND Realm = ?';
 935       $realmparam = $part_export->option('realm');
 936     }
 937
 938     my $sth = $dbh->prepare("SELECT $attrib, $str2time AcctStartTime $closing
 939                                FROM radacct
 940                                WHERE UserName = ?
 941                                  $realm
 942                                ORDER BY AcctStartTime DESC LIMIT 1
 943     ") or die $dbh->errstr;
 944     $sth->execute($username, ($realm ? $realmparam : ()) )
 945       or die $sth->errstr;
 946
 947     my $row = $sth->fetchrow_arrayref;
 948     if ( defined($row->[0]) && $row->[1] > $AcctStartTime ) {
 949       $value = $row->[0];
 950       $AcctStartTime = $row->[1];
 951     }
 952
 953     warn "$mes done\n"
 954       if $DEBUG;
 955
 956   }
 957
 958   $value;
 959
 960 }
 961
 962 =item get_session_history TIMESTAMP_START TIMESTAMP_END
 963
 964 See L<FS::svc_acct/get_session_history>.  Equivalent to
 965 $cust_svc->svc_x->get_session_history, but more efficient.  Meaningless for
 966 records where B<svcdb> is not "svc_acct".
 967
 968 =cut
 969
 970 sub get_session_history {
 971   my($self, $start, $end, $attrib) = @_;
 972
 973   #$attrib ???
 974
 975   my @part_export = $self->part_svc->part_export_usage;
 976   die "no accounting-capable exports are enabled for ". $self->part_svc->svc.
 977       " service definition"
 978     unless @part_export;
 979     #or return undef;
 980
 981   my @sessions = ();
 982
 983   foreach my $part_export ( @part_export ) {
 984     push @sessions,
 985       @{ $part_export->usage_sessions( $start, $end, $self->svc_x ) };
 986   }
 987
 988   @sessions;
 989
 990 }
 991
 992 =item tickets  [ STATUS ]
 993
 994 Returns an array of hashes representing the tickets linked to this service.
 995
 996 An optional status (or arrayref or hashref of statuses) may be specified.
 997
 998 =cut
 999
1000 sub tickets {
1001   my $self = shift;
1002   my $status = ( @_ && $_[0] ) ? shift : '';
1003
1004   my $conf = FS::Conf->new;
1005   my $num = $conf->config('cust_main-max_tickets') || 10;
1006   my @tickets = ();
1007
1008   if ( $conf->config('ticket_system') ) {
1009     unless ( $conf->config('ticket_system-custom_priority_field') ) {
1010
1011       @tickets = @{ FS::TicketSystem->service_tickets( $self->svcnum,
1012                                                        $num,
1013                                                        undef,
1014                                                        $status,
1015                                                      )
1016                   };
1017
1018     } else {
1019
1020       foreach my $priority (
1021         $conf->config('ticket_system-custom_priority_field-values'), ''
1022       ) {
1023         last if scalar(@tickets) >= $num;
1024         push @tickets,
1025         @{ FS::TicketSystem->service_tickets( $self->svcnum,
1026                                               $num - scalar(@tickets),
1027                                               $priority,
1028                                               $status,
1029                                             )
1030          };
1031       }
1032     }
1033   }
1034   (@tickets);
1035 }
1036
1037 sub API_getinfo {
1038   my $self = shift;
1039   my $svc_x = $self->svc_x;
1040  +{ ( map { $_=>$self->$_ } $self->fields ),
1041     ( map { $svc_x=>$svc_x->$_ } $svc_x->fields ),
1042   };
1043 }
1044
1045 =back
1046
1047 =head1 SUBROUTINES
1048
1049 =over 4
1050
1051 =item smart_search OPTION => VALUE ...
1052
1053 Accepts the option I<search>, the string to search for.  The string will
1054 be searched for as a username, email address, IP address, MAC address,
1055 phone number, and hardware serial number.  Unlike the I<smart_search> on
1056 customers, this always requires an exact match.
1057
1058 =cut
1059
1060 # though perhaps it should be fuzzy in some cases?
1061
1062 sub smart_search {
1063   my %param = __PACKAGE__->smart_search_param(@_);
1064   qsearch(\%param);
1065 }
1066
1067 sub smart_search_param {
1068   my $class = shift;
1069   my %opt = @_;
1070
1071   my $string = $opt{'search'};
1072   $string =~ s/(^\s+|\s+$)//; #trim leading & trailing whitespace
1073
1074   my @or =
1075       map { my $table = $_;
1076             my $search_sql = "FS::$table"->search_sql($string);
1077
1078             "SELECT $table.svcnum AS svcnum, '$table' AS svcdb ".
1079             "FROM $table WHERE $search_sql";
1080           }
1081       FS::part_svc->svc_tables;
1082
1083   if ( $string =~ /^(\d+)$/ ) {
1084     unshift @or, "SELECT cust_svc.svcnum, NULL as svcdb FROM cust_svc WHERE agent_svcid = $1";
1085   }
1086
1087   my $addl_from = " RIGHT JOIN (\n" . join("\nUNION\n", @or) . "\n) AS svc_all ".
1088                   " ON (svc_all.svcnum = cust_svc.svcnum) ";
1089
1090   my @extra_sql;
1091
1092   push @extra_sql, $FS::CurrentUser::CurrentUser->agentnums_sql(
1093     'null_right' => 'View/link unlinked services'
1094   );
1095   my $extra_sql = ' WHERE '.join(' AND ', @extra_sql);
1096   #for agentnum
1097   $addl_from  .=  ' LEFT JOIN cust_pkg  USING ( pkgnum  )'.
1098                   FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg').
1099                   ' LEFT JOIN part_svc  USING ( svcpart )';
1100
1101   (
1102     'table'     => 'cust_svc',
1103     'select'    => 'svc_all.svcnum AS svcnum, '.
1104                    'COALESCE(svc_all.svcdb, part_svc.svcdb) AS svcdb, '.
1105                    'cust_svc.*',
1106     'addl_from' => $addl_from,
1107     'hashref'   => {},
1108     'extra_sql' => $extra_sql,
1109   );
1110 }
1111
1112 sub _upgrade_data {
1113   my $class = shift;
1114
1115   # fix missing (deleted by mistake) svc_x records
1116   warn "searching for missing svc_x records...\n";
1117   my %search = (
1118     'table'     => 'cust_svc',
1119     'select'    => 'cust_svc.*',
1120     'addl_from' => ' LEFT JOIN ( ' .
1121       join(' UNION ',
1122         map { "SELECT svcnum FROM $_" }
1123         FS::part_svc->svc_tables
1124       ) . ' ) AS svc_all ON cust_svc.svcnum = svc_all.svcnum',
1125     'extra_sql' => ' WHERE svc_all.svcnum IS NULL',
1126   );
1127   my @svcs = qsearch(\%search);
1128   warn "found ".scalar(@svcs)."\n";
1129
1130   local $FS::Record::nowarn_classload = 1; # for h_svc_
1131   local $FS::svc_Common::noexport_hack = 1; # because we're inserting services
1132
1133   my %h_search = (
1134     'hashref'  => { history_action => 'delete' },
1135     'order_by' => ' ORDER BY history_date DESC LIMIT 1',
1136   );
1137   foreach my $cust_svc (@svcs) {
1138     my $svcnum = $cust_svc->svcnum;
1139     my $svcdb = $cust_svc->part_svc->svcdb;
1140     $h_search{'hashref'}{'svcnum'} = $svcnum;
1141     $h_search{'table'} = "h_$svcdb";
1142     my $h_svc_x = qsearchs(\%h_search)
1143       or next;
1144     my $class = "FS::$svcdb";
1145     my $new_svc_x = $class->new({ $h_svc_x->hash });
1146     my $error = $new_svc_x->insert;
1147     warn "error repairing svcnum $svcnum ($svcdb) from history:\n$error\n"
1148       if $error;
1149   }
1150
1151   '';
1152 }
1153
1154 =back
1155
1156 =head1 BUGS
1157
1158 Behaviour of changing the svcpart of cust_svc records is undefined and should
1159 possibly be prohibited, and pkg_svc records are not checked.
1160
1161 pkg_svc records are not checked in general (here).
1162
1163 Deleting this record doesn't check or delete the svc_* record associated
1164 with this record.
1165
1166 In seconds_since_sqlradacct, specifying a DATASRC/USERNAME/PASSWORD instead of
1167 a DBI database handle is not yet implemented.
1168
1169 =head1 SEE ALSO
1170
1171 L<FS::Record>, L<FS::cust_pkg>, L<FS::part_svc>, L<FS::pkg_svc>,
1172 schema.html from the base documentation
1173
1174 =cut
1175
1176 1;
1177