FS/FS/cust_svc.pm

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