FS/FS/svc_acct.pm

   1 package FS::svc_acct;
   2
   3 use strict;
   4 use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles
   5              $dir_prefix @shells $usernamemin
   6              $usernamemax $passwordmin $passwordmax
   7              $username_ampersand $username_letter $username_letterfirst
   8              $username_noperiod $username_nounderscore $username_nodash
   9              $username_uppercase $username_percent
  10              $password_noampersand $password_noexclamation
  11              $warning_template $warning_from $warning_subject $warning_mimetype
  12              $warning_cc
  13              $smtpmachine
  14              $radius_password $radius_ip
  15              $dirhash
  16              @saltset @pw_set );
  17 use Scalar::Util qw( blessed );
  18 use Carp;
  19 use Fcntl qw(:flock);
  20 use Date::Format;
  21 use Crypt::PasswdMD5 1.2;
  22 use Data::Dumper;
  23 use Authen::Passphrase;
  24 use FS::UID qw( datasrc driver_name );
  25 use FS::Conf;
  26 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
  27 use FS::Msgcat qw(gettext);
  28 use FS::UI::bytecount;
  29 use FS::part_pkg;
  30 use FS::svc_Common;
  31 use FS::cust_svc;
  32 use FS::part_svc;
  33 use FS::svc_acct_pop;
  34 use FS::cust_main_invoice;
  35 use FS::svc_domain;
  36 use FS::raddb;
  37 use FS::queue;
  38 use FS::radius_usergroup;
  39 use FS::export_svc;
  40 use FS::part_export;
  41 use FS::svc_forward;
  42 use FS::svc_www;
  43 use FS::cdr;
  44
  45 @ISA = qw( FS::svc_Common );
  46
  47 $DEBUG = 0;
  48 $me = '[FS::svc_acct]';
  49
  50 #ask FS::UID to run this stuff for us later
  51 FS::UID->install_callback( sub {
  52   $conf = new FS::Conf;
  53   $dir_prefix = $conf->config('home');
  54   @shells = $conf->config('shells');
  55   $usernamemin = $conf->config('usernamemin') || 2;
  56   $usernamemax = $conf->config('usernamemax');
  57   $passwordmin = $conf->config('passwordmin') || 6;
  58   $passwordmax = $conf->config('passwordmax') || 8;
  59   $username_letter = $conf->exists('username-letter');
  60   $username_letterfirst = $conf->exists('username-letterfirst');
  61   $username_noperiod = $conf->exists('username-noperiod');
  62   $username_nounderscore = $conf->exists('username-nounderscore');
  63   $username_nodash = $conf->exists('username-nodash');
  64   $username_uppercase = $conf->exists('username-uppercase');
  65   $username_ampersand = $conf->exists('username-ampersand');
  66   $username_percent = $conf->exists('username-percent');
  67   $password_noampersand = $conf->exists('password-noexclamation');
  68   $password_noexclamation = $conf->exists('password-noexclamation');
  69   $dirhash = $conf->config('dirhash') || 0;
  70   if ( $conf->exists('warning_email') ) {
  71     $warning_template = new Text::Template (
  72       TYPE   => 'ARRAY',
  73       SOURCE => [ map "$_\n", $conf->config('warning_email') ]
  74     ) or warn "can't create warning email template: $Text::Template::ERROR";
  75     $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
  76     $warning_subject = $conf->config('warning_email-subject') || 'Warning';
  77     $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
  78     $warning_cc = $conf->config('warning_email-cc');
  79   } else {
  80     $warning_template = '';
  81     $warning_from = '';
  82     $warning_subject = '';
  83     $warning_mimetype = '';
  84     $warning_cc = '';
  85   }
  86   $smtpmachine = $conf->config('smtpmachine');
  87   $radius_password = $conf->config('radius-password') || 'Password';
  88   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
  89   @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
  90 }
  91 );
  92
  93 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  94 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
  95
  96 sub _cache {
  97   my $self = shift;
  98   my ( $hashref, $cache ) = @_;
  99   if ( $hashref->{'svc_acct_svcnum'} ) {
 100     $self->{'_domsvc'} = FS::svc_domain->new( {
 101       'svcnum'   => $hashref->{'domsvc'},
 102       'domain'   => $hashref->{'svc_acct_domain'},
 103       'catchall' => $hashref->{'svc_acct_catchall'},
 104     } );
 105   }
 106 }
 107
 108 =head1 NAME
 109
 110 FS::svc_acct - Object methods for svc_acct records
 111
 112 =head1 SYNOPSIS
 113
 114   use FS::svc_acct;
 115
 116   $record = new FS::svc_acct \%hash;
 117   $record = new FS::svc_acct { 'column' => 'value' };
 118
 119   $error = $record->insert;
 120
 121   $error = $new_record->replace($old_record);
 122
 123   $error = $record->delete;
 124
 125   $error = $record->check;
 126
 127   $error = $record->suspend;
 128
 129   $error = $record->unsuspend;
 130
 131   $error = $record->cancel;
 132
 133   %hash = $record->radius;
 134
 135   %hash = $record->radius_reply;
 136
 137   %hash = $record->radius_check;
 138
 139   $domain = $record->domain;
 140
 141   $svc_domain = $record->svc_domain;
 142
 143   $email = $record->email;
 144
 145   $seconds_since = $record->seconds_since($timestamp);
 146
 147 =head1 DESCRIPTION
 148
 149 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 150 FS::svc_Common.  The following fields are currently supported:
 151
 152 =over 4
 153
 154 =item svcnum - primary key (assigned automatcially for new accounts)
 155
 156 =item username
 157
 158 =item _password - generated if blank
 159
 160 =item _password_encoding - plain, crypt, ldap (or empty for autodetection)
 161
 162 =item sec_phrase - security phrase
 163
 164 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 165
 166 =item uid
 167
 168 =item gid
 169
 170 =item finger - GECOS
 171
 172 =item dir - set automatically if blank (and uid is not)
 173
 174 =item shell
 175
 176 =item quota - (unimplementd)
 177
 178 =item slipip - IP address
 179
 180 =item seconds -
 181
 182 =item upbytes -
 183
 184 =item downbytes -
 185
 186 =item totalbytes -
 187
 188 =item domsvc - svcnum from svc_domain
 189
 190 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
 191
 192 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
 193
 194 =back
 195
 196 =head1 METHODS
 197
 198 =over 4
 199
 200 =item new HASHREF
 201
 202 Creates a new account.  To add the account to the database, see L<"insert">.
 203
 204 =cut
 205
 206 sub table_info {
 207   {
 208     'name'   => 'Account',
 209     'longname_plural' => 'Access accounts and mailboxes',
 210     'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
 211     'display_weight' => 10,
 212     'cancel_weight'  => 50,
 213     'fields' => {
 214         'dir'       => 'Home directory',
 215         'uid'       => {
 216                          label     => 'UID',
 217                          def_label => 'UID (set to fixed and blank for no UIDs)',
 218                          type      => 'text',
 219                        },
 220         'slipip'    => 'IP address',
 221     #    'popnum'    => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
 222         'popnum'    => {
 223                          label => 'Access number',
 224                          type => 'select',
 225                          select_table => 'svc_acct_pop',
 226                          select_key   => 'popnum',
 227                          select_label => 'city',
 228                          disable_select => 1,
 229                        },
 230         'username'  => {
 231                          label => 'Username',
 232                          type => 'text',
 233                          disable_default => 1,
 234                          disable_fixed => 1,
 235                          disable_select => 1,
 236                        },
 237         'quota'     => {
 238                          label => 'Quota',
 239                          type => 'text',
 240                          disable_inventory => 1,
 241                          disable_select => 1,
 242                        },
 243         '_password' => 'Password',
 244         'gid'       => {
 245                          label     => 'GID',
 246                          def_label => 'GID (when blank, defaults to UID)',
 247                          type      => 'text',
 248                        },
 249         'shell'     => {
 250                          #desc =>'Shell (all service definitions should have a default or fixed shell that is present in the <b>shells</b> configuration file, set to blank for no shell tracking)',
 251                          label    => 'Shell',
 252                          def_label=> 'Shell (set to blank for no shell tracking)',
 253                          type     =>'select',
 254                          #select_list => [ $conf->config('shells') ],
 255                          select_list => [ $conf ? $conf->config('shells') : () ],
 256                          disable_inventory => 1,
 257                          disable_select => 1,
 258                        },
 259         'finger'    => 'Real name', # (GECOS)',
 260         'domsvc'    => {
 261                          label     => 'Domain',
 262                          #def_label => 'svcnum from svc_domain',
 263                          type      => 'select',
 264                          select_table => 'svc_domain',
 265                          select_key   => 'svcnum',
 266                          select_label => 'domain',
 267                          disable_inventory => 1,
 268
 269                        },
 270         'usergroup' => {
 271                          label => 'RADIUS groups',
 272                          type  => 'radius_usergroup_selector',
 273                          disable_inventory => 1,
 274                          disable_select => 1,
 275                        },
 276         'seconds'   => { label => 'Seconds',
 277                          label_sort => 'with Time Remaining',
 278                          type  => 'text',
 279                          disable_inventory => 1,
 280                          disable_select => 1,
 281                          disable_part_svc_column => 1,
 282                        },
 283         'upbytes'   => { label => 'Upload',
 284                          type  => 'text',
 285                          disable_inventory => 1,
 286                          disable_select => 1,
 287                          'format' => \&FS::UI::bytecount::display_bytecount,
 288                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 289                          disable_part_svc_column => 1,
 290                        },
 291         'downbytes' => { label => 'Download',
 292                          type  => 'text',
 293                          disable_inventory => 1,
 294                          disable_select => 1,
 295                          'format' => \&FS::UI::bytecount::display_bytecount,
 296                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 297                          disable_part_svc_column => 1,
 298                        },
 299         'totalbytes'=> { label => 'Total up and download',
 300                          type  => 'text',
 301                          disable_inventory => 1,
 302                          disable_select => 1,
 303                          'format' => \&FS::UI::bytecount::display_bytecount,
 304                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 305                          disable_part_svc_column => 1,
 306                        },
 307         'seconds_threshold'   => { label => 'Seconds threshold',
 308                                    type  => 'text',
 309                                    disable_inventory => 1,
 310                                    disable_select => 1,
 311                                    disable_part_svc_column => 1,
 312                                  },
 313         'upbytes_threshold'   => { label => 'Upload threshold',
 314                                    type  => 'text',
 315                                    disable_inventory => 1,
 316                                    disable_select => 1,
 317                                    'format' => \&FS::UI::bytecount::display_bytecount,
 318                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 319                                    disable_part_svc_column => 1,
 320                                  },
 321         'downbytes_threshold' => { label => 'Download threshold',
 322                                    type  => 'text',
 323                                    disable_inventory => 1,
 324                                    disable_select => 1,
 325                                    'format' => \&FS::UI::bytecount::display_bytecount,
 326                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 327                                    disable_part_svc_column => 1,
 328                                  },
 329         'totalbytes_threshold'=> { label => 'Total up and download threshold',
 330                                    type  => 'text',
 331                                    disable_inventory => 1,
 332                                    disable_select => 1,
 333                                    'format' => \&FS::UI::bytecount::display_bytecount,
 334                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 335                                    disable_part_svc_column => 1,
 336                                  },
 337         'last_login'=>           {
 338                                    label     => 'Last login',
 339                                    type      => 'disabled',
 340                                  },
 341         'last_logout'=>          {
 342                                    label     => 'Last logout',
 343                                    type      => 'disabled',
 344                                  },
 345     },
 346   };
 347 }
 348
 349 sub table { 'svc_acct'; }
 350
 351 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
 352
 353 sub _fieldhandlers {
 354   {
 355     #false laziness with edit/svc_acct.cgi
 356     'usergroup' => sub {
 357                          my( $self, $groups ) = @_;
 358                          if ( ref($groups) eq 'ARRAY' ) {
 359                            $groups;
 360                          } elsif ( length($groups) ) {
 361                            [ split(/\s*,\s*/, $groups) ];
 362                          } else {
 363                            [];
 364                          }
 365                        },
 366   };
 367 }
 368
 369 sub last_login {
 370   shift->_lastlog('in', @_);
 371 }
 372
 373 sub last_logout {
 374   shift->_lastlog('out', @_);
 375 }
 376
 377 sub _lastlog {
 378   my( $self, $op, $time ) = @_;
 379
 380   if ( defined($time) ) {
 381     warn "$me last_log$op called on svcnum ". $self->svcnum.
 382          ' ('. $self->email. "): $time\n"
 383       if $DEBUG;
 384
 385     my $dbh = dbh;
 386
 387     my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
 388     warn "$me $sql\n"
 389       if $DEBUG;
 390
 391     my $sth = $dbh->prepare( $sql )
 392       or die "Error preparing $sql: ". $dbh->errstr;
 393     my $rv = $sth->execute($time, $self->svcnum);
 394     die "Error executing $sql: ". $sth->errstr
 395       unless defined($rv);
 396     die "Can't update last_log$op for svcnum". $self->svcnum
 397       if $rv == 0;
 398
 399     $self->{'Hash'}->{"last_log$op"} = $time;
 400   }else{
 401     $self->getfield("last_log$op");
 402   }
 403 }
 404
 405 =item search_sql STRING
 406
 407 Class method which returns an SQL fragment to search for the given string.
 408
 409 =cut
 410
 411 sub search_sql {
 412   my( $class, $string ) = @_;
 413   if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
 414     my( $username, $domain ) = ( $1, $2 );
 415     my $q_username = dbh->quote($username);
 416     my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
 417     if ( @svc_domain ) {
 418       "svc_acct.username = $q_username AND ( ".
 419         join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
 420       " )";
 421     } else {
 422       '1 = 0'; #false
 423     }
 424   } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
 425     ' ( '.
 426       $class->search_sql_field('slipip',   $string ).
 427     ' OR '.
 428       $class->search_sql_field('username', $string ).
 429     ' ) ';
 430   } else {
 431     $class->search_sql_field('username', $string);
 432   }
 433 }
 434
 435 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
 436
 437 Returns the "username@domain" string for this account.
 438
 439 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
 440 history records.
 441
 442 =cut
 443
 444 sub label {
 445   my $self = shift;
 446   $self->email(@_);
 447 }
 448
 449 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
 450
 451 Returns a longer string label for this acccount ("Real Name <username@domain>"
 452 if available, or "username@domain").
 453
 454 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
 455 history records.
 456
 457 =cut
 458
 459 sub label_long {
 460   my $self = shift;
 461   ( $self->finger =~ /\S/ )
 462     ? $self->finger. ' <'.$self->label(@_).'>'
 463     : $self->label(@_);
 464 }
 465
 466 =item insert [ , OPTION => VALUE ... ]
 467
 468 Adds this account to the database.  If there is an error, returns the error,
 469 otherwise returns false.
 470
 471 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 472 defined.  An FS::cust_svc record will be created and inserted.
 473
 474 The additional field I<usergroup> can optionally be defined; if so it should
 475 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 476
 477 The additional field I<child_objects> can optionally be defined; if so it
 478 should contain an arrayref of FS::tablename objects.  They will have their
 479 svcnum fields set and will be inserted after this record, but before any
 480 exports are run.  Each element of the array can also optionally be a
 481 two-element array reference containing the child object and the name of an
 482 alternate field to be filled in with the newly-inserted svcnum, for example
 483 C<[ $svc_forward, 'srcsvc' ]>
 484
 485 Currently available options are: I<depend_jobnum>
 486
 487 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
 488 jobnums), all provisioning jobs will have a dependancy on the supplied
 489 jobnum(s) (they will not run until the specific job(s) complete(s)).
 490
 491 (TODOC: L<FS::queue> and L<freeside-queued>)
 492
 493 (TODOC: new exports!)
 494
 495 =cut
 496
 497 sub insert {
 498   my $self = shift;
 499   my %options = @_;
 500
 501   if ( $DEBUG ) {
 502     warn "[$me] insert called on $self: ". Dumper($self).
 503          "\nwith options: ". Dumper(%options);
 504   }
 505
 506   local $SIG{HUP} = 'IGNORE';
 507   local $SIG{INT} = 'IGNORE';
 508   local $SIG{QUIT} = 'IGNORE';
 509   local $SIG{TERM} = 'IGNORE';
 510   local $SIG{TSTP} = 'IGNORE';
 511   local $SIG{PIPE} = 'IGNORE';
 512
 513   my $oldAutoCommit = $FS::UID::AutoCommit;
 514   local $FS::UID::AutoCommit = 0;
 515   my $dbh = dbh;
 516
 517   my $error = $self->check;
 518   return $error if $error;
 519
 520   if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
 521     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
 522     unless ( $cust_svc ) {
 523       $dbh->rollback if $oldAutoCommit;
 524       return "no cust_svc record found for svcnum ". $self->svcnum;
 525     }
 526     $self->pkgnum($cust_svc->pkgnum);
 527     $self->svcpart($cust_svc->svcpart);
 528   }
 529
 530   # set usage fields and thresholds if unset but set in a package def
 531   if ( $self->pkgnum ) {
 532     my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
 533     my $part_pkg = $cust_pkg->part_pkg if $cust_pkg;
 534     if ( $part_pkg && $part_pkg->can('usage_valuehash') ) {
 535
 536       my %values = $part_pkg->usage_valuehash;
 537       my $multiplier = $conf->exists('svc_acct-usage_threshold')
 538                          ? 1 - $conf->config('svc_acct-usage_threshold')/100
 539                          : 0.20;
 540
 541       foreach ( keys %values ) {
 542         next if $self->getfield($_);
 543         $self->setfield( $_, $values{$_} );
 544         $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) );
 545       }
 546
 547     }
 548   }
 549
 550   my @jobnums;
 551   $error = $self->SUPER::insert(
 552     'jobnums'       => \@jobnums,
 553     'child_objects' => $self->child_objects,
 554     %options,
 555   );
 556   if ( $error ) {
 557     $dbh->rollback if $oldAutoCommit;
 558     return $error;
 559   }
 560
 561   if ( $self->usergroup ) {
 562     foreach my $groupname ( @{$self->usergroup} ) {
 563       my $radius_usergroup = new FS::radius_usergroup ( {
 564         svcnum    => $self->svcnum,
 565         groupname => $groupname,
 566       } );
 567       my $error = $radius_usergroup->insert;
 568       if ( $error ) {
 569         $dbh->rollback if $oldAutoCommit;
 570         return $error;
 571       }
 572     }
 573   }
 574
 575   unless ( $skip_fuzzyfiles ) {
 576     $error = $self->queue_fuzzyfiles_update;
 577     if ( $error ) {
 578       $dbh->rollback if $oldAutoCommit;
 579       return "updating fuzzy search cache: $error";
 580     }
 581   }
 582
 583   my $cust_pkg = $self->cust_svc->cust_pkg;
 584
 585   if ( $cust_pkg ) {
 586     my $cust_main = $cust_pkg->cust_main;
 587     my $agentnum = $cust_main->agentnum;
 588
 589     if (   $conf->exists('emailinvoiceautoalways')
 590         || $conf->exists('emailinvoiceauto')
 591         && ! $cust_main->invoicing_list_emailonly
 592        ) {
 593       my @invoicing_list = $cust_main->invoicing_list;
 594       push @invoicing_list, $self->email;
 595       $cust_main->invoicing_list(\@invoicing_list);
 596     }
 597
 598     #welcome email
 599     my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
 600       = ('','','','','','');
 601
 602     if ( $conf->exists('welcome_email', $agentnum) ) {
 603       $welcome_template = new Text::Template (
 604         TYPE   => 'ARRAY',
 605         SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
 606       ) or warn "can't create welcome email template: $Text::Template::ERROR";
 607       $welcome_from = $conf->config('welcome_email-from', $agentnum);
 608         # || 'your-isp-is-dum'
 609       $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
 610         || 'Welcome';
 611       $welcome_subject_template = new Text::Template (
 612         TYPE   => 'STRING',
 613         SOURCE => $welcome_subject,
 614       ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
 615       $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
 616         || 'text/plain';
 617     }
 618     if ( $welcome_template && $cust_pkg ) {
 619       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
 620       if ( $to ) {
 621
 622         my %hash = (
 623                      'custnum'  => $self->custnum,
 624                      'username' => $self->username,
 625                      'password' => $self->_password,
 626                      'first'    => $cust_main->first,
 627                      'last'     => $cust_main->getfield('last'),
 628                      'pkg'      => $cust_pkg->part_pkg->pkg,
 629                    );
 630         my $wqueue = new FS::queue {
 631           'svcnum' => $self->svcnum,
 632           'job'    => 'FS::svc_acct::send_email'
 633         };
 634         my $error = $wqueue->insert(
 635           'to'       => $to,
 636           'from'     => $welcome_from,
 637           'subject'  => $welcome_subject_template->fill_in( HASH => \%hash, ),
 638           'mimetype' => $welcome_mimetype,
 639           'body'     => $welcome_template->fill_in( HASH => \%hash, ),
 640         );
 641         if ( $error ) {
 642           $dbh->rollback if $oldAutoCommit;
 643           return "error queuing welcome email: $error";
 644         }
 645
 646         if ( $options{'depend_jobnum'} ) {
 647           warn "$me depend_jobnum found; adding to welcome email dependancies"
 648             if $DEBUG;
 649           if ( ref($options{'depend_jobnum'}) ) {
 650             warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
 651                  "to welcome email dependancies"
 652               if $DEBUG;
 653             push @jobnums, @{ $options{'depend_jobnum'} };
 654           } else {
 655             warn "$me adding job $options{'depend_jobnum'} ".
 656                  "to welcome email dependancies"
 657               if $DEBUG;
 658             push @jobnums, $options{'depend_jobnum'};
 659           }
 660         }
 661
 662         foreach my $jobnum ( @jobnums ) {
 663           my $error = $wqueue->depend_insert($jobnum);
 664           if ( $error ) {
 665             $dbh->rollback if $oldAutoCommit;
 666             return "error queuing welcome email job dependancy: $error";
 667           }
 668         }
 669
 670       }
 671
 672     }
 673
 674   } # if ( $cust_pkg )
 675
 676   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 677   ''; #no error
 678 }
 679
 680 =item delete
 681
 682 Deletes this account from the database.  If there is an error, returns the
 683 error, otherwise returns false.
 684
 685 The corresponding FS::cust_svc record will be deleted as well.
 686
 687 (TODOC: new exports!)
 688
 689 =cut
 690
 691 sub delete {
 692   my $self = shift;
 693
 694   return "can't delete system account" if $self->_check_system;
 695
 696   return "Can't delete an account which is a (svc_forward) source!"
 697     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 698
 699   return "Can't delete an account which is a (svc_forward) destination!"
 700     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 701
 702   return "Can't delete an account with (svc_www) web service!"
 703     if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
 704
 705   # what about records in session ? (they should refer to history table)
 706
 707   local $SIG{HUP} = 'IGNORE';
 708   local $SIG{INT} = 'IGNORE';
 709   local $SIG{QUIT} = 'IGNORE';
 710   local $SIG{TERM} = 'IGNORE';
 711   local $SIG{TSTP} = 'IGNORE';
 712   local $SIG{PIPE} = 'IGNORE';
 713
 714   my $oldAutoCommit = $FS::UID::AutoCommit;
 715   local $FS::UID::AutoCommit = 0;
 716   my $dbh = dbh;
 717
 718   foreach my $cust_main_invoice (
 719     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 720   ) {
 721     unless ( defined($cust_main_invoice) ) {
 722       warn "WARNING: something's wrong with qsearch";
 723       next;
 724     }
 725     my %hash = $cust_main_invoice->hash;
 726     $hash{'dest'} = $self->email;
 727     my $new = new FS::cust_main_invoice \%hash;
 728     my $error = $new->replace($cust_main_invoice);
 729     if ( $error ) {
 730       $dbh->rollback if $oldAutoCommit;
 731       return $error;
 732     }
 733   }
 734
 735   foreach my $svc_domain (
 736     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 737   ) {
 738     my %hash = new FS::svc_domain->hash;
 739     $hash{'catchall'} = '';
 740     my $new = new FS::svc_domain \%hash;
 741     my $error = $new->replace($svc_domain);
 742     if ( $error ) {
 743       $dbh->rollback if $oldAutoCommit;
 744       return $error;
 745     }
 746   }
 747
 748   my $error = $self->SUPER::delete;
 749   if ( $error ) {
 750     $dbh->rollback if $oldAutoCommit;
 751     return $error;
 752   }
 753
 754   foreach my $radius_usergroup (
 755     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 756   ) {
 757     my $error = $radius_usergroup->delete;
 758     if ( $error ) {
 759       $dbh->rollback if $oldAutoCommit;
 760       return $error;
 761     }
 762   }
 763
 764   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 765   '';
 766 }
 767
 768 =item replace OLD_RECORD
 769
 770 Replaces OLD_RECORD with this one in the database.  If there is an error,
 771 returns the error, otherwise returns false.
 772
 773 The additional field I<usergroup> can optionally be defined; if so it should
 774 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 775
 776
 777 =cut
 778
 779 sub replace {
 780   my $new = shift;
 781
 782   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 783               ? shift
 784               : $new->replace_old;
 785
 786   warn "$me replacing $old with $new\n" if $DEBUG;
 787
 788   my $error;
 789
 790   return "can't modify system account" if $old->_check_system;
 791
 792   {
 793     #no warnings 'numeric';  #alas, a 5.006-ism
 794     local($^W) = 0;
 795
 796     foreach my $xid (qw( uid gid )) {
 797
 798       return "Can't change $xid!"
 799         if ! $conf->exists("svc_acct-edit_$xid")
 800            && $old->$xid() != $new->$xid()
 801            && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
 802     }
 803
 804   }
 805
 806   #change homdir when we change username
 807   $new->setfield('dir', '') if $old->username ne $new->username;
 808
 809   local $SIG{HUP} = 'IGNORE';
 810   local $SIG{INT} = 'IGNORE';
 811   local $SIG{QUIT} = 'IGNORE';
 812   local $SIG{TERM} = 'IGNORE';
 813   local $SIG{TSTP} = 'IGNORE';
 814   local $SIG{PIPE} = 'IGNORE';
 815
 816   my $oldAutoCommit = $FS::UID::AutoCommit;
 817   local $FS::UID::AutoCommit = 0;
 818   my $dbh = dbh;
 819
 820   # redundant, but so $new->usergroup gets set
 821   $error = $new->check;
 822   return $error if $error;
 823
 824   $old->usergroup( [ $old->radius_groups ] );
 825   if ( $DEBUG ) {
 826     warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
 827     warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
 828   }
 829   if ( $new->usergroup ) {
 830     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 831     my @newgroups = @{$new->usergroup};
 832     foreach my $oldgroup ( @{$old->usergroup} ) {
 833       if ( grep { $oldgroup eq $_ } @newgroups ) {
 834         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 835         next;
 836       }
 837       my $radius_usergroup = qsearchs('radius_usergroup', {
 838         svcnum    => $old->svcnum,
 839         groupname => $oldgroup,
 840       } );
 841       my $error = $radius_usergroup->delete;
 842       if ( $error ) {
 843         $dbh->rollback if $oldAutoCommit;
 844         return "error deleting radius_usergroup $oldgroup: $error";
 845       }
 846     }
 847
 848     foreach my $newgroup ( @newgroups ) {
 849       my $radius_usergroup = new FS::radius_usergroup ( {
 850         svcnum    => $new->svcnum,
 851         groupname => $newgroup,
 852       } );
 853       my $error = $radius_usergroup->insert;
 854       if ( $error ) {
 855         $dbh->rollback if $oldAutoCommit;
 856         return "error adding radius_usergroup $newgroup: $error";
 857       }
 858     }
 859
 860   }
 861
 862   $error = $new->SUPER::replace($old, @_);
 863   if ( $error ) {
 864     $dbh->rollback if $oldAutoCommit;
 865     return $error if $error;
 866   }
 867
 868   if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
 869     $error = $new->queue_fuzzyfiles_update;
 870     if ( $error ) {
 871       $dbh->rollback if $oldAutoCommit;
 872       return "updating fuzzy search cache: $error";
 873     }
 874   }
 875
 876   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 877   ''; #no error
 878 }
 879
 880 =item queue_fuzzyfiles_update
 881
 882 Used by insert & replace to update the fuzzy search cache
 883
 884 =cut
 885
 886 sub queue_fuzzyfiles_update {
 887   my $self = shift;
 888
 889   local $SIG{HUP} = 'IGNORE';
 890   local $SIG{INT} = 'IGNORE';
 891   local $SIG{QUIT} = 'IGNORE';
 892   local $SIG{TERM} = 'IGNORE';
 893   local $SIG{TSTP} = 'IGNORE';
 894   local $SIG{PIPE} = 'IGNORE';
 895
 896   my $oldAutoCommit = $FS::UID::AutoCommit;
 897   local $FS::UID::AutoCommit = 0;
 898   my $dbh = dbh;
 899
 900   my $queue = new FS::queue {
 901     'svcnum' => $self->svcnum,
 902     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 903   };
 904   my $error = $queue->insert($self->username);
 905   if ( $error ) {
 906     $dbh->rollback if $oldAutoCommit;
 907     return "queueing job (transaction rolled back): $error";
 908   }
 909
 910   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 911   '';
 912
 913 }
 914
 915
 916 =item suspend
 917
 918 Suspends this account by calling export-specific suspend hooks.  If there is
 919 an error, returns the error, otherwise returns false.
 920
 921 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 922
 923 =cut
 924
 925 sub suspend {
 926   my $self = shift;
 927   return "can't suspend system account" if $self->_check_system;
 928   $self->SUPER::suspend(@_);
 929 }
 930
 931 =item unsuspend
 932
 933 Unsuspends this account by by calling export-specific suspend hooks.  If there
 934 is an error, returns the error, otherwise returns false.
 935
 936 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 937
 938 =cut
 939
 940 sub unsuspend {
 941   my $self = shift;
 942   my %hash = $self->hash;
 943   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 944     $hash{_password} = $1;
 945     my $new = new FS::svc_acct ( \%hash );
 946     my $error = $new->replace($self);
 947     return $error if $error;
 948   }
 949
 950   $self->SUPER::unsuspend(@_);
 951 }
 952
 953 =item cancel
 954
 955 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 956
 957 If the B<auto_unset_catchall> configuration option is set, this method will
 958 automatically remove any references to the canceled service in the catchall
 959 field of svc_domain.  This allows packages that contain both a svc_domain and
 960 its catchall svc_acct to be canceled in one step.
 961
 962 =cut
 963
 964 sub cancel {
 965   # Only one thing to do at this level
 966   my $self = shift;
 967   foreach my $svc_domain (
 968       qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
 969     if($conf->exists('auto_unset_catchall')) {
 970       my %hash = $svc_domain->hash;
 971       $hash{catchall} = '';
 972       my $new = new FS::svc_domain ( \%hash );
 973       my $error = $new->replace($svc_domain);
 974       return $error if $error;
 975     } else {
 976       return "cannot unprovision svc_acct #".$self->svcnum.
 977           " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
 978     }
 979   }
 980
 981   $self->SUPER::cancel(@_);
 982 }
 983
 984
 985 =item check
 986
 987 Checks all fields to make sure this is a valid service.  If there is an error,
 988 returns the error, otherwise returns false.  Called by the insert and replace
 989 methods.
 990
 991 Sets any fixed values; see L<FS::part_svc>.
 992
 993 =cut
 994
 995 sub check {
 996   my $self = shift;
 997
 998   my($recref) = $self->hashref;
 999
1000   my $x = $self->setfixed( $self->_fieldhandlers );
1001   return $x unless ref($x);
1002   my $part_svc = $x;
1003
1004   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1005     $self->usergroup(
1006       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1007   }
1008
1009   my $error = $self->ut_numbern('svcnum')
1010               #|| $self->ut_number('domsvc')
1011               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
1012               || $self->ut_textn('sec_phrase')
1013               || $self->ut_snumbern('seconds')
1014               || $self->ut_snumbern('upbytes')
1015               || $self->ut_snumbern('downbytes')
1016               || $self->ut_snumbern('totalbytes')
1017               || $self->ut_enum( '_password_encoding',
1018                                  [ '', qw( plain crypt ldap ) ]
1019                                )
1020   ;
1021   return $error if $error;
1022
1023   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1024   if ( $username_uppercase ) {
1025     $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
1026       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1027     $recref->{username} = $1;
1028   } else {
1029     $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
1030       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1031     $recref->{username} = $1;
1032   }
1033
1034   if ( $username_letterfirst ) {
1035     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1036   } elsif ( $username_letter ) {
1037     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1038   }
1039   if ( $username_noperiod ) {
1040     $recref->{username} =~ /\./ and return gettext('illegal_username');
1041   }
1042   if ( $username_nounderscore ) {
1043     $recref->{username} =~ /_/ and return gettext('illegal_username');
1044   }
1045   if ( $username_nodash ) {
1046     $recref->{username} =~ /\-/ and return gettext('illegal_username');
1047   }
1048   unless ( $username_ampersand ) {
1049     $recref->{username} =~ /\&/ and return gettext('illegal_username');
1050   }
1051   unless ( $username_percent ) {
1052     $recref->{username} =~ /\%/ and return gettext('illegal_username');
1053   }
1054
1055   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1056   $recref->{popnum} = $1;
1057   return "Unknown popnum" unless
1058     ! $recref->{popnum} ||
1059     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1060
1061   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1062
1063     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1064     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1065
1066     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1067     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1068     #not all systems use gid=uid
1069     #you can set a fixed gid in part_svc
1070
1071     return "Only root can have uid 0"
1072       if $recref->{uid} == 0
1073          && $recref->{username} !~ /^(root|toor|smtp)$/;
1074
1075     unless ( $recref->{username} eq 'sync' ) {
1076       if ( grep $_ eq $recref->{shell}, @shells ) {
1077         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1078       } else {
1079         return "Illegal shell \`". $self->shell. "\'; ".
1080                "shells configuration value contains: @shells";
1081       }
1082     } else {
1083       $recref->{shell} = '/bin/sync';
1084     }
1085
1086   } else {
1087     $recref->{gid} ne '' ?
1088       return "Can't have gid without uid" : ( $recref->{gid}='' );
1089     #$recref->{dir} ne '' ?
1090     #  return "Can't have directory without uid" : ( $recref->{dir}='' );
1091     $recref->{shell} ne '' ?
1092       return "Can't have shell without uid" : ( $recref->{shell}='' );
1093   }
1094
1095   unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1096
1097     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1098       or return "Illegal directory: ". $recref->{dir};
1099     $recref->{dir} = $1;
1100     return "Illegal directory"
1101       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1102     return "Illegal directory"
1103       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1104     unless ( $recref->{dir} ) {
1105       $recref->{dir} = $dir_prefix . '/';
1106       if ( $dirhash > 0 ) {
1107         for my $h ( 1 .. $dirhash ) {
1108           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1109         }
1110       } elsif ( $dirhash < 0 ) {
1111         for my $h ( reverse $dirhash .. -1 ) {
1112           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1113         }
1114       }
1115       $recref->{dir} .= $recref->{username};
1116     ;
1117     }
1118
1119   }
1120
1121   #  $error = $self->ut_textn('finger');
1122   #  return $error if $error;
1123   if ( $self->getfield('finger') eq '' ) {
1124     my $cust_pkg = $self->svcnum
1125       ? $self->cust_svc->cust_pkg
1126       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1127     if ( $cust_pkg ) {
1128       my $cust_main = $cust_pkg->cust_main;
1129       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1130     }
1131   }
1132   $self->getfield('finger') =~
1133     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1134       or return "Illegal finger: ". $self->getfield('finger');
1135   $self->setfield('finger', $1);
1136
1137   $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1138   $recref->{quota} = $1;
1139
1140   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1141     if ( $recref->{slipip} eq '' ) {
1142       $recref->{slipip} = '';
1143     } elsif ( $recref->{slipip} eq '0e0' ) {
1144       $recref->{slipip} = '0e0';
1145     } else {
1146       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1147         or return "Illegal slipip: ". $self->slipip;
1148       $recref->{slipip} = $1;
1149     }
1150
1151   }
1152
1153   #arbitrary RADIUS stuff; allow ut_textn for now
1154   foreach ( grep /^radius_/, fields('svc_acct') ) {
1155     $self->ut_textn($_);
1156   }
1157
1158   if ( $recref->{_password_encoding} eq 'ldap' ) {
1159
1160     if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1161       $recref->{_password} = uc($1).$2;
1162     } else {
1163       return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1164     }
1165
1166   } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1167
1168     if ( $recref->{_password} =~
1169            #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1170            /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1171        ) {
1172
1173       $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1174
1175     } else {
1176       return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1177     }
1178
1179   } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1180
1181     #generate a password if it is blank
1182     $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1183       unless length( $recref->{_password} );
1184
1185     if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1186       $recref->{_password} = $1;
1187     } else {
1188       return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1189              FS::Msgcat::_gettext('illegal_password_characters').
1190              ": ". $recref->{_password};
1191     }
1192
1193     if ( $password_noampersand ) {
1194       $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1195     }
1196     if ( $password_noexclamation ) {
1197       $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1198     }
1199
1200   } else {
1201
1202     #carp "warning: _password_encoding unspecified\n";
1203
1204     #generate a password if it is blank
1205     unless ( length( $recref->{_password} ) ) {
1206
1207       $recref->{_password} =
1208         join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1209       $recref->{_password_encoding} = 'plain';
1210
1211     } else {
1212
1213       #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1214       if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1215         $recref->{_password} = $1.$3;
1216         $recref->{_password_encoding} = 'plain';
1217       } elsif ( $recref->{_password} =~
1218                   /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
1219               ) {
1220         $recref->{_password} = $1.$3;
1221         $recref->{_password_encoding} = 'crypt';
1222       } elsif ( $recref->{_password} eq '*' ) {
1223         $recref->{_password} = '*';
1224         $recref->{_password_encoding} = 'crypt';
1225       } elsif ( $recref->{_password} eq '!' ) {
1226         $recref->{_password_encoding} = 'crypt';
1227         $recref->{_password} = '!';
1228       } elsif ( $recref->{_password} eq '!!' ) {
1229         $recref->{_password} = '!!';
1230         $recref->{_password_encoding} = 'crypt';
1231       } else {
1232         #return "Illegal password";
1233         return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1234                FS::Msgcat::_gettext('illegal_password_characters').
1235                ": ". $recref->{_password};
1236       }
1237
1238     }
1239
1240   }
1241
1242   $self->SUPER::check;
1243
1244 }
1245
1246 =item _check_system
1247
1248 Internal function to check the username against the list of system usernames
1249 from the I<system_usernames> configuration value.  Returns true if the username
1250 is listed on the system username list.
1251
1252 =cut
1253
1254 sub _check_system {
1255   my $self = shift;
1256   scalar( grep { $self->username eq $_ || $self->email eq $_ }
1257                $conf->config('system_usernames')
1258         );
1259 }
1260
1261 =item _check_duplicate
1262
1263 Internal method to check for duplicates usernames, username@domain pairs and
1264 uids.
1265
1266 If the I<global_unique-username> configuration value is set to B<username> or
1267 B<username@domain>, enforces global username or username@domain uniqueness.
1268
1269 In all cases, check for duplicate uids and usernames or username@domain pairs
1270 per export and with identical I<svcpart> values.
1271
1272 =cut
1273
1274 sub _check_duplicate {
1275   my $self = shift;
1276
1277   my $global_unique = $conf->config('global_unique-username') || 'none';
1278   return '' if $global_unique eq 'disabled';
1279
1280   $self->lock_table;
1281
1282   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1283   unless ( $part_svc ) {
1284     return 'unknown svcpart '. $self->svcpart;
1285   }
1286
1287   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1288                  qsearch( 'svc_acct', { 'username' => $self->username } );
1289   return gettext('username_in_use')
1290     if $global_unique eq 'username' && @dup_user;
1291
1292   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1293                        qsearch( 'svc_acct', { 'username' => $self->username,
1294                                               'domsvc'   => $self->domsvc } );
1295   return gettext('username_in_use')
1296     if $global_unique eq 'username@domain' && @dup_userdomain;
1297
1298   my @dup_uid;
1299   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1300        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
1301     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1302                qsearch( 'svc_acct', { 'uid' => $self->uid } );
1303   } else {
1304     @dup_uid = ();
1305   }
1306
1307   if ( @dup_user || @dup_userdomain || @dup_uid ) {
1308     my $exports = FS::part_export::export_info('svc_acct');
1309     my %conflict_user_svcpart;
1310     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1311
1312     foreach my $part_export ( $part_svc->part_export ) {
1313
1314       #this will catch to the same exact export
1315       my @svcparts = map { $_->svcpart } $part_export->export_svc;
1316
1317       #this will catch to exports w/same exporthost+type ???
1318       #my @other_part_export = qsearch('part_export', {
1319       #  'machine'    => $part_export->machine,
1320       #  'exporttype' => $part_export->exporttype,
1321       #} );
1322       #foreach my $other_part_export ( @other_part_export ) {
1323       #  push @svcparts, map { $_->svcpart }
1324       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1325       #}
1326
1327       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1328       #silly kludge to avoid uninitialized value errors
1329       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1330                      ? $exports->{$part_export->exporttype}{'nodomain'}
1331                      : '';
1332       if ( $nodomain =~ /^Y/i ) {
1333         $conflict_user_svcpart{$_} = $part_export->exportnum
1334           foreach @svcparts;
1335       } else {
1336         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1337           foreach @svcparts;
1338       }
1339     }
1340
1341     foreach my $dup_user ( @dup_user ) {
1342       my $dup_svcpart = $dup_user->cust_svc->svcpart;
1343       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1344         return "duplicate username ". $self->username.
1345                ": conflicts with svcnum ". $dup_user->svcnum.
1346                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1347       }
1348     }
1349
1350     foreach my $dup_userdomain ( @dup_userdomain ) {
1351       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1352       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1353         return "duplicate username\@domain ". $self->email.
1354                ": conflicts with svcnum ". $dup_userdomain->svcnum.
1355                " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1356       }
1357     }
1358
1359     foreach my $dup_uid ( @dup_uid ) {
1360       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1361       if ( exists($conflict_user_svcpart{$dup_svcpart})
1362            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1363         return "duplicate uid ". $self->uid.
1364                ": conflicts with svcnum ". $dup_uid->svcnum.
1365                " via exportnum ".
1366                ( $conflict_user_svcpart{$dup_svcpart}
1367                  || $conflict_userdomain_svcpart{$dup_svcpart} );
1368       }
1369     }
1370
1371   }
1372
1373   return '';
1374
1375 }
1376
1377 =item radius
1378
1379 Depriciated, use radius_reply instead.
1380
1381 =cut
1382
1383 sub radius {
1384   carp "FS::svc_acct::radius depriciated, use radius_reply";
1385   $_[0]->radius_reply;
1386 }
1387
1388 =item radius_reply
1389
1390 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1391 reply attributes of this record.
1392
1393 Note that this is now the preferred method for reading RADIUS attributes -
1394 accessing the columns directly is discouraged, as the column names are
1395 expected to change in the future.
1396
1397 =cut
1398
1399 sub radius_reply {
1400   my $self = shift;
1401
1402   return %{ $self->{'radius_reply'} }
1403     if exists $self->{'radius_reply'};
1404
1405   my %reply =
1406     map {
1407       /^(radius_(.*))$/;
1408       my($column, $attrib) = ($1, $2);
1409       #$attrib =~ s/_/\-/g;
1410       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1411     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1412
1413   if ( $self->slipip && $self->slipip ne '0e0' ) {
1414     $reply{$radius_ip} = $self->slipip;
1415   }
1416
1417   if ( $self->seconds !~ /^$/ ) {
1418     $reply{'Session-Timeout'} = $self->seconds;
1419   }
1420
1421   %reply;
1422 }
1423
1424 =item radius_check
1425
1426 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1427 check attributes of this record.
1428
1429 Note that this is now the preferred method for reading RADIUS attributes -
1430 accessing the columns directly is discouraged, as the column names are
1431 expected to change in the future.
1432
1433 =cut
1434
1435 sub radius_check {
1436   my $self = shift;
1437
1438   return %{ $self->{'radius_check'} }
1439     if exists $self->{'radius_check'};
1440
1441   my %check =
1442     map {
1443       /^(rc_(.*))$/;
1444       my($column, $attrib) = ($1, $2);
1445       #$attrib =~ s/_/\-/g;
1446       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1447     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1448
1449
1450   my($pw_attrib, $password) = $self->radius_password;
1451   $check{$pw_attrib} = $password;
1452
1453   my $cust_svc = $self->cust_svc;
1454   die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1455     unless $cust_svc;
1456   my $cust_pkg = $cust_svc->cust_pkg;
1457   if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1458     $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1459   }
1460
1461   %check;
1462
1463 }
1464
1465 =item radius_password
1466
1467 Returns a key/value pair containing the RADIUS attribute name and value
1468 for the password.
1469
1470 =cut
1471
1472 sub radius_password {
1473   my $self = shift;
1474
1475   my($pw_attrib, $password);
1476   if ( $self->_password_encoding eq 'ldap' ) {
1477
1478     $pw_attrib = 'Password-With-Header';
1479     $password = $self->_password;
1480
1481   } elsif ( $self->_password_encoding eq 'crypt' ) {
1482
1483     $pw_attrib = 'Crypt-Password';
1484     $password = $self->_password;
1485
1486   } elsif ( $self->_password_encoding eq 'plain' ) {
1487
1488     $pw_attrib = $radius_password; #Cleartext-Password?  man rlm_pap
1489     $password = $self->_password;
1490
1491   } else {
1492
1493     $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1494     $password = $self->_password;
1495
1496   }
1497
1498   ($pw_attrib, $password);
1499
1500 }
1501
1502 =item snapshot
1503
1504 This method instructs the object to "snapshot" or freeze RADIUS check and
1505 reply attributes to the current values.
1506
1507 =cut
1508
1509 #bah, my english is too broken this morning
1510 #Of note is the "Expiration" attribute, which, for accounts in prepaid packages, is typically defined on-the-fly as the associated packages cust_pkg.bill.  (This is used by
1511 #the FS::cust_pkg's replace method to trigger the correct export updates when
1512 #package dates change)
1513
1514 sub snapshot {
1515   my $self = shift;
1516
1517   $self->{$_} = { $self->$_() }
1518     foreach qw( radius_reply radius_check );
1519
1520 }
1521
1522 =item forget_snapshot
1523
1524 This methos instructs the object to forget any previously snapshotted
1525 RADIUS check and reply attributes.
1526
1527 =cut
1528
1529 sub forget_snapshot {
1530   my $self = shift;
1531
1532   delete $self->{$_}
1533     foreach qw( radius_reply radius_check );
1534
1535 }
1536
1537 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1538
1539 Returns the domain associated with this account.
1540
1541 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1542 history records.
1543
1544 =cut
1545
1546 sub domain {
1547   my $self = shift;
1548   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1549   my $svc_domain = $self->svc_domain(@_)
1550     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1551   $svc_domain->domain;
1552 }
1553
1554 =item svc_domain
1555
1556 Returns the FS::svc_domain record for this account's domain (see
1557 L<FS::svc_domain>).
1558
1559 =cut
1560
1561 # FS::h_svc_acct has a history-aware svc_domain override
1562
1563 sub svc_domain {
1564   my $self = shift;
1565   $self->{'_domsvc'}
1566     ? $self->{'_domsvc'}
1567     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1568 }
1569
1570 =item cust_svc
1571
1572 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1573
1574 =cut
1575
1576 #inherited from svc_Common
1577
1578 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1579
1580 Returns an email address associated with the account.
1581
1582 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1583 history records.
1584
1585 =cut
1586
1587 sub email {
1588   my $self = shift;
1589   $self->username. '@'. $self->domain(@_);
1590 }
1591
1592 =item acct_snarf
1593
1594 Returns an array of FS::acct_snarf records associated with the account.
1595 If the acct_snarf table does not exist or there are no associated records,
1596 an empty list is returned
1597
1598 =cut
1599
1600 sub acct_snarf {
1601   my $self = shift;
1602   return () unless dbdef->table('acct_snarf');
1603   eval "use FS::acct_snarf;";
1604   die $@ if $@;
1605   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1606 }
1607
1608 =item decrement_upbytes OCTETS
1609
1610 Decrements the I<upbytes> field of this record by the given amount.  If there
1611 is an error, returns the error, otherwise returns false.
1612
1613 =cut
1614
1615 sub decrement_upbytes {
1616   shift->_op_usage('-', 'upbytes', @_);
1617 }
1618
1619 =item increment_upbytes OCTETS
1620
1621 Increments the I<upbytes> field of this record by the given amount.  If there
1622 is an error, returns the error, otherwise returns false.
1623
1624 =cut
1625
1626 sub increment_upbytes {
1627   shift->_op_usage('+', 'upbytes', @_);
1628 }
1629
1630 =item decrement_downbytes OCTETS
1631
1632 Decrements the I<downbytes> field of this record by the given amount.  If there
1633 is an error, returns the error, otherwise returns false.
1634
1635 =cut
1636
1637 sub decrement_downbytes {
1638   shift->_op_usage('-', 'downbytes', @_);
1639 }
1640
1641 =item increment_downbytes OCTETS
1642
1643 Increments the I<downbytes> field of this record by the given amount.  If there
1644 is an error, returns the error, otherwise returns false.
1645
1646 =cut
1647
1648 sub increment_downbytes {
1649   shift->_op_usage('+', 'downbytes', @_);
1650 }
1651
1652 =item decrement_totalbytes OCTETS
1653
1654 Decrements the I<totalbytes> field of this record by the given amount.  If there
1655 is an error, returns the error, otherwise returns false.
1656
1657 =cut
1658
1659 sub decrement_totalbytes {
1660   shift->_op_usage('-', 'totalbytes', @_);
1661 }
1662
1663 =item increment_totalbytes OCTETS
1664
1665 Increments the I<totalbytes> field of this record by the given amount.  If there
1666 is an error, returns the error, otherwise returns false.
1667
1668 =cut
1669
1670 sub increment_totalbytes {
1671   shift->_op_usage('+', 'totalbytes', @_);
1672 }
1673
1674 =item decrement_seconds SECONDS
1675
1676 Decrements the I<seconds> field of this record by the given amount.  If there
1677 is an error, returns the error, otherwise returns false.
1678
1679 =cut
1680
1681 sub decrement_seconds {
1682   shift->_op_usage('-', 'seconds', @_);
1683 }
1684
1685 =item increment_seconds SECONDS
1686
1687 Increments the I<seconds> field of this record by the given amount.  If there
1688 is an error, returns the error, otherwise returns false.
1689
1690 =cut
1691
1692 sub increment_seconds {
1693   shift->_op_usage('+', 'seconds', @_);
1694 }
1695
1696
1697 my %op2action = (
1698   '-' => 'suspend',
1699   '+' => 'unsuspend',
1700 );
1701 my %op2condition = (
1702   '-' => sub { my($self, $column, $amount) = @_;
1703                $self->$column - $amount <= 0;
1704              },
1705   '+' => sub { my($self, $column, $amount) = @_;
1706                $self->$column + $amount > 0;
1707              },
1708 );
1709 my %op2warncondition = (
1710   '-' => sub { my($self, $column, $amount) = @_;
1711                my $threshold = $column . '_threshold';
1712                $self->$column - $amount <= $self->$threshold + 0;
1713              },
1714   '+' => sub { my($self, $column, $amount) = @_;
1715                $self->$column + $amount > 0;
1716              },
1717 );
1718
1719 sub _op_usage {
1720   my( $self, $op, $column, $amount ) = @_;
1721
1722   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1723        ' ('. $self->email. "): $op $amount\n"
1724     if $DEBUG;
1725
1726   return '' unless $amount;
1727
1728   local $SIG{HUP} = 'IGNORE';
1729   local $SIG{INT} = 'IGNORE';
1730   local $SIG{QUIT} = 'IGNORE';
1731   local $SIG{TERM} = 'IGNORE';
1732   local $SIG{TSTP} = 'IGNORE';
1733   local $SIG{PIPE} = 'IGNORE';
1734
1735   my $oldAutoCommit = $FS::UID::AutoCommit;
1736   local $FS::UID::AutoCommit = 0;
1737   my $dbh = dbh;
1738
1739   my $sql = "UPDATE svc_acct SET $column = ".
1740             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1741             " $op ? WHERE svcnum = ?";
1742   warn "$me $sql\n"
1743     if $DEBUG;
1744
1745   my $sth = $dbh->prepare( $sql )
1746     or die "Error preparing $sql: ". $dbh->errstr;
1747   my $rv = $sth->execute($amount, $self->svcnum);
1748   die "Error executing $sql: ". $sth->errstr
1749     unless defined($rv);
1750   die "Can't update $column for svcnum". $self->svcnum
1751     if $rv == 0;
1752
1753   my $action = $op2action{$op};
1754
1755   if ( &{$op2condition{$op}}($self, $column, $amount) &&
1756         ( $action eq 'suspend'   && !$self->overlimit
1757        || $action eq 'unsuspend' &&  $self->overlimit )
1758      ) {
1759     foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1760       if ($part_export->option('overlimit_groups')) {
1761         my ($new,$old);
1762         my $other = new FS::svc_acct $self->hashref;
1763         my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1764                        ($self, $part_export->option('overlimit_groups'));
1765         $other->usergroup( $groups );
1766         if ($action eq 'suspend'){
1767           $new = $other; $old = $self;
1768         }else{
1769           $new = $self; $old = $other;
1770         }
1771         my $error = $part_export->export_replace($new, $old);
1772         $error ||= $self->overlimit($action);
1773         if ( $error ) {
1774           $dbh->rollback if $oldAutoCommit;
1775           return "Error replacing radius groups in export, ${op}: $error";
1776         }
1777       }
1778     }
1779   }
1780
1781   if ( $conf->exists("svc_acct-usage_$action")
1782        && &{$op2condition{$op}}($self, $column, $amount)    ) {
1783     #my $error = $self->$action();
1784     my $error = $self->cust_svc->cust_pkg->$action();
1785     # $error ||= $self->overlimit($action);
1786     if ( $error ) {
1787       $dbh->rollback if $oldAutoCommit;
1788       return "Error ${action}ing: $error";
1789     }
1790   }
1791
1792   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1793     my $wqueue = new FS::queue {
1794       'svcnum' => $self->svcnum,
1795       'job'    => 'FS::svc_acct::reached_threshold',
1796     };
1797
1798     my $to = '';
1799     if ($op eq '-'){
1800       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1801     }
1802
1803     # x_threshold race
1804     my $error = $wqueue->insert(
1805       'svcnum' => $self->svcnum,
1806       'op'     => $op,
1807       'column' => $column,
1808       'to'     => $to,
1809     );
1810     if ( $error ) {
1811       $dbh->rollback if $oldAutoCommit;
1812       return "Error queuing threshold activity: $error";
1813     }
1814   }
1815
1816   warn "$me update successful; committing\n"
1817     if $DEBUG;
1818   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1819   '';
1820
1821 }
1822
1823 sub set_usage {
1824   my( $self, $valueref ) = @_;
1825
1826   warn "$me set_usage called for svcnum ". $self->svcnum.
1827        ' ('. $self->email. "): ".
1828        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1829     if $DEBUG;
1830
1831   local $SIG{HUP} = 'IGNORE';
1832   local $SIG{INT} = 'IGNORE';
1833   local $SIG{QUIT} = 'IGNORE';
1834   local $SIG{TERM} = 'IGNORE';
1835   local $SIG{TSTP} = 'IGNORE';
1836   local $SIG{PIPE} = 'IGNORE';
1837
1838   local $FS::svc_Common::noexport_hack = 1;
1839   my $oldAutoCommit = $FS::UID::AutoCommit;
1840   local $FS::UID::AutoCommit = 0;
1841   my $dbh = dbh;
1842
1843   my $reset = 0;
1844   my %handyhash = ();
1845   foreach my $field (keys %$valueref){
1846     $reset = 1 if $valueref->{$field};
1847     $self->setfield($field, $valueref->{$field});
1848     $self->setfield( $field.'_threshold',
1849                      int($self->getfield($field)
1850                          * ( $conf->exists('svc_acct-usage_threshold')
1851                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
1852                              : 0.20
1853                            )
1854                        )
1855                      );
1856     $handyhash{$field} = $self->getfield($field);
1857     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1858   }
1859   #my $error = $self->replace;   #NO! we avoid the call to ->check for
1860   #die $error if $error;         #services not explicity changed via the UI
1861
1862   my $sql = "UPDATE svc_acct SET " .
1863     join (',', map { "$_ =  ?" } (keys %handyhash) ).
1864     " WHERE svcnum = ?";
1865
1866   warn "$me $sql\n"
1867     if $DEBUG;
1868
1869   if (scalar(keys %handyhash)) {
1870     my $sth = $dbh->prepare( $sql )
1871       or die "Error preparing $sql: ". $dbh->errstr;
1872     my $rv = $sth->execute((values %handyhash), $self->svcnum);
1873     die "Error executing $sql: ". $sth->errstr
1874       unless defined($rv);
1875     die "Can't update usage for svcnum ". $self->svcnum
1876       if $rv == 0;
1877   }
1878
1879   if ( $reset ) {
1880     my $error;
1881
1882     if ($self->overlimit) {
1883       $error = $self->overlimit('unsuspend');
1884       foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1885         if ($part_export->option('overlimit_groups')) {
1886           my $old = new FS::svc_acct $self->hashref;
1887           my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1888                          ($self, $part_export->option('overlimit_groups'));
1889           $old->usergroup( $groups );
1890           $error ||= $part_export->export_replace($self, $old);
1891         }
1892       }
1893     }
1894
1895     if ( $conf->exists("svc_acct-usage_unsuspend")) {
1896       $error ||= $self->cust_svc->cust_pkg->unsuspend;
1897     }
1898     if ( $error ) {
1899       $dbh->rollback if $oldAutoCommit;
1900       return "Error unsuspending: $error";
1901     }
1902   }
1903
1904   warn "$me update successful; committing\n"
1905     if $DEBUG;
1906   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1907   '';
1908
1909 }
1910
1911
1912 =item recharge HASHREF
1913
1914   Increments usage columns by the amount specified in HASHREF as
1915   column=>amount pairs.
1916
1917 =cut
1918
1919 sub recharge {
1920   my ($self, $vhash) = @_;
1921
1922   if ( $DEBUG ) {
1923     warn "[$me] recharge called on $self: ". Dumper($self).
1924          "\nwith vhash: ". Dumper($vhash);
1925   }
1926
1927   my $oldAutoCommit = $FS::UID::AutoCommit;
1928   local $FS::UID::AutoCommit = 0;
1929   my $dbh = dbh;
1930   my $error = '';
1931
1932   foreach my $column (keys %$vhash){
1933     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1934   }
1935
1936   if ( $error ) {
1937     $dbh->rollback if $oldAutoCommit;
1938   }else{
1939     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1940   }
1941   return $error;
1942 }
1943
1944 =item is_rechargeable
1945
1946 Returns true if this svc_account can be "recharged" and false otherwise.
1947
1948 =cut
1949
1950 sub is_rechargable {
1951   my $self = shift;
1952   $self->seconds ne ''
1953     || $self->upbytes ne ''
1954     || $self->downbytes ne ''
1955     || $self->totalbytes ne '';
1956 }
1957
1958 =item seconds_since TIMESTAMP
1959
1960 Returns the number of seconds this account has been online since TIMESTAMP,
1961 according to the session monitor (see L<FS::Session>).
1962
1963 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1964 L<Time::Local> and L<Date::Parse> for conversion functions.
1965
1966 =cut
1967
1968 #note: POD here, implementation in FS::cust_svc
1969 sub seconds_since {
1970   my $self = shift;
1971   $self->cust_svc->seconds_since(@_);
1972 }
1973
1974 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1975
1976 Returns the numbers of seconds this account has been online between
1977 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1978 external SQL radacct table, specified via sqlradius export.  Sessions which
1979 started in the specified range but are still open are counted from session
1980 start to the end of the range (unless they are over 1 day old, in which case
1981 they are presumed missing their stop record and not counted).  Also, sessions
1982 which end in the range but started earlier are counted from the start of the
1983 range to session end.  Finally, sessions which start before the range but end
1984 after are counted for the entire range.
1985
1986 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1987 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1988 functions.
1989
1990 =cut
1991
1992 #note: POD here, implementation in FS::cust_svc
1993 sub seconds_since_sqlradacct {
1994   my $self = shift;
1995   $self->cust_svc->seconds_since_sqlradacct(@_);
1996 }
1997
1998 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1999
2000 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2001 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2002 TIMESTAMP_END (exclusive).
2003
2004 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2005 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2006 functions.
2007
2008 =cut
2009
2010 #note: POD here, implementation in FS::cust_svc
2011 sub attribute_since_sqlradacct {
2012   my $self = shift;
2013   $self->cust_svc->attribute_since_sqlradacct(@_);
2014 }
2015
2016 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2017
2018 Returns an array of hash references of this customers login history for the
2019 given time range.  (document this better)
2020
2021 =cut
2022
2023 sub get_session_history {
2024   my $self = shift;
2025   $self->cust_svc->get_session_history(@_);
2026 }
2027
2028 =item last_login_text
2029
2030 Returns text describing the time of last login.
2031
2032 =cut
2033
2034 sub last_login_text {
2035   my $self = shift;
2036   $self->last_login ? ctime($self->last_login) : 'unknown';
2037 }
2038
2039 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2040
2041 =cut
2042
2043 sub get_cdrs {
2044   my($self, $start, $end, %opt ) = @_;
2045
2046   my $did = $self->username; #yup
2047
2048   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2049
2050   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2051
2052   #SELECT $for_update * FROM cdr
2053   #  WHERE calldate >= $start #need a conversion
2054   #    AND calldate <  $end   #ditto
2055   #    AND (    charged_party = "$did"
2056   #          OR charged_party = "$prefix$did" #if length($prefix);
2057   #          OR ( ( charged_party IS NULL OR charged_party = '' )
2058   #               AND
2059   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2060   #             )
2061   #        )
2062   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
2063
2064   my $charged_or_src;
2065   if ( length($prefix) ) {
2066     $charged_or_src =
2067       " AND (    charged_party = '$did'
2068               OR charged_party = '$prefix$did'
2069               OR ( ( charged_party IS NULL OR charged_party = '' )
2070                    AND
2071                    ( src = '$did' OR src = '$prefix$did' )
2072                  )
2073             )
2074       ";
2075   } else {
2076     $charged_or_src =
2077       " AND (    charged_party = '$did'
2078               OR ( ( charged_party IS NULL OR charged_party = '' )
2079                    AND
2080                    src = '$did'
2081                  )
2082             )
2083       ";
2084
2085   }
2086
2087   qsearch(
2088     'select'    => "$for_update *",
2089     'table'     => 'cdr',
2090     'hashref'   => {
2091                      #( freesidestatus IS NULL OR freesidestatus = '' )
2092                      'freesidestatus' => '',
2093                    },
2094     'extra_sql' => $charged_or_src,
2095
2096   );
2097
2098 }
2099
2100 =item radius_groups
2101
2102 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2103
2104 =cut
2105
2106 sub radius_groups {
2107   my $self = shift;
2108   if ( $self->usergroup ) {
2109     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2110       unless ref($self->usergroup) eq 'ARRAY';
2111     #when provisioning records, export callback runs in svc_Common.pm before
2112     #radius_usergroup records can be inserted...
2113     @{$self->usergroup};
2114   } else {
2115     map { $_->groupname }
2116       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2117   }
2118 }
2119
2120 =item clone_suspended
2121
2122 Constructor used by FS::part_export::_export_suspend fallback.  Document
2123 better.
2124
2125 =cut
2126
2127 sub clone_suspended {
2128   my $self = shift;
2129   my %hash = $self->hash;
2130   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2131   new FS::svc_acct \%hash;
2132 }
2133
2134 =item clone_kludge_unsuspend
2135
2136 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2137 better.
2138
2139 =cut
2140
2141 sub clone_kludge_unsuspend {
2142   my $self = shift;
2143   my %hash = $self->hash;
2144   $hash{_password} = '';
2145   new FS::svc_acct \%hash;
2146 }
2147
2148 =item check_password
2149
2150 Checks the supplied password against the (possibly encrypted) password in the
2151 database.  Returns true for a successful authentication, false for no match.
2152
2153 Currently supported encryptions are: classic DES crypt() and MD5
2154
2155 =cut
2156
2157 sub check_password {
2158   my($self, $check_password) = @_;
2159
2160   #remove old-style SUSPENDED kludge, they should be allowed to login to
2161   #self-service and pay up
2162   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2163
2164   if ( $self->_password_encoding eq 'ldap' ) {
2165
2166     my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2167     return $auth->match($check_password);
2168
2169   } elsif ( $self->_password_encoding eq 'crypt' ) {
2170
2171     my $auth = from_crypt Authen::Passphrase $self->_password;
2172     return $auth->match($check_password);
2173
2174   } elsif ( $self->_password_encoding eq 'plain' ) {
2175
2176     return $check_password eq $password;
2177
2178   } else {
2179
2180     #XXX this could be replaced with Authen::Passphrase stuff
2181
2182     if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2183       return 0;
2184     } elsif ( length($password) < 13 ) { #plaintext
2185       $check_password eq $password;
2186     } elsif ( length($password) == 13 ) { #traditional DES crypt
2187       crypt($check_password, $password) eq $password;
2188     } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2189       unix_md5_crypt($check_password, $password) eq $password;
2190     } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2191       warn "Can't check password: Blowfish encryption not yet supported, ".
2192            "svcnum ".  $self->svcnum. "\n";
2193       0;
2194     } else {
2195       warn "Can't check password: Unrecognized encryption for svcnum ".
2196            $self->svcnum. "\n";
2197       0;
2198     }
2199
2200   }
2201
2202 }
2203
2204 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2205
2206 Returns an encrypted password, either by passing through an encrypted password
2207 in the database or by encrypting a plaintext password from the database.
2208
2209 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2210 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2211 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2212 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2213 encryption type is only used if the password is not already encrypted in the
2214 database.
2215
2216 =cut
2217
2218 sub crypt_password {
2219   my $self = shift;
2220
2221   if ( $self->_password_encoding eq 'ldap' ) {
2222
2223     if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2224       my $plain = $2;
2225
2226       #XXX this could be replaced with Authen::Passphrase stuff
2227
2228       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2229       if ( $encryption eq 'crypt' ) {
2230         crypt(
2231           $self->_password,
2232           $saltset[int(rand(64))].$saltset[int(rand(64))]
2233         );
2234       } elsif ( $encryption eq 'md5' ) {
2235         unix_md5_crypt( $self->_password );
2236       } elsif ( $encryption eq 'blowfish' ) {
2237         croak "unknown encryption method $encryption";
2238       } else {
2239         croak "unknown encryption method $encryption";
2240       }
2241
2242     } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2243       $1;
2244     }
2245
2246   } elsif ( $self->_password_encoding eq 'crypt' ) {
2247
2248     return $self->_password;
2249
2250   } elsif ( $self->_password_encoding eq 'plain' ) {
2251
2252     #XXX this could be replaced with Authen::Passphrase stuff
2253
2254     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2255     if ( $encryption eq 'crypt' ) {
2256       crypt(
2257         $self->_password,
2258         $saltset[int(rand(64))].$saltset[int(rand(64))]
2259       );
2260     } elsif ( $encryption eq 'md5' ) {
2261       unix_md5_crypt( $self->_password );
2262     } elsif ( $encryption eq 'blowfish' ) {
2263       croak "unknown encryption method $encryption";
2264     } else {
2265       croak "unknown encryption method $encryption";
2266     }
2267
2268   } else {
2269
2270     if ( length($self->_password) == 13
2271          || $self->_password =~ /^\$(1|2a?)\$/
2272          || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2273        )
2274     {
2275       $self->_password;
2276     } else {
2277
2278       #XXX this could be replaced with Authen::Passphrase stuff
2279
2280       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2281       if ( $encryption eq 'crypt' ) {
2282         crypt(
2283           $self->_password,
2284           $saltset[int(rand(64))].$saltset[int(rand(64))]
2285         );
2286       } elsif ( $encryption eq 'md5' ) {
2287         unix_md5_crypt( $self->_password );
2288       } elsif ( $encryption eq 'blowfish' ) {
2289         croak "unknown encryption method $encryption";
2290       } else {
2291         croak "unknown encryption method $encryption";
2292       }
2293
2294     }
2295
2296   }
2297
2298 }
2299
2300 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2301
2302 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2303 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2304 "{MD5}5426824942db4253f87a1009fd5d2d4".
2305
2306 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2307 to work the same as the B</crypt_password> method.
2308
2309 =cut
2310
2311 sub ldap_password {
2312   my $self = shift;
2313   #eventually should check a "password-encoding" field
2314
2315   if ( $self->_password_encoding eq 'ldap' ) {
2316
2317     return $self->_password;
2318
2319   } elsif ( $self->_password_encoding eq 'crypt' ) {
2320
2321     if ( length($self->_password) == 13 ) { #crypt
2322       return '{CRYPT}'. $self->_password;
2323     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2324       return '{MD5}'. $1;
2325     #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2326     #  die "Blowfish encryption not supported in this context, svcnum ".
2327     #      $self->svcnum. "\n";
2328     } else {
2329       warn "encryption method not (yet?) supported in LDAP context";
2330       return '{CRYPT}*'; #unsupported, should not auth
2331     }
2332
2333   } elsif ( $self->_password_encoding eq 'plain' ) {
2334
2335     return '{PLAIN}'. $self->_password;
2336
2337     #return '{CLEARTEXT}'. $self->_password; #?
2338
2339   } else {
2340
2341     if ( length($self->_password) == 13 ) { #crypt
2342       return '{CRYPT}'. $self->_password;
2343     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2344       return '{MD5}'. $1;
2345     } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2346       warn "Blowfish encryption not supported in this context, svcnum ".
2347           $self->svcnum. "\n";
2348       return '{CRYPT}*';
2349
2350     #are these two necessary anymore?
2351     } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2352       return '{SSHA}'. $1;
2353     } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2354       return '{NS-MTA-MD5}'. $1;
2355
2356     } else { #plaintext
2357       return '{PLAIN}'. $self->_password;
2358
2359       #return '{CLEARTEXT}'. $self->_password; #?
2360
2361       #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2362       #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2363       #if ( $encryption eq 'crypt' ) {
2364       #  return '{CRYPT}'. crypt(
2365       #    $self->_password,
2366       #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2367       #  );
2368       #} elsif ( $encryption eq 'md5' ) {
2369       #  unix_md5_crypt( $self->_password );
2370       #} elsif ( $encryption eq 'blowfish' ) {
2371       #  croak "unknown encryption method $encryption";
2372       #} else {
2373       #  croak "unknown encryption method $encryption";
2374       #}
2375     }
2376
2377   }
2378
2379 }
2380
2381 =item domain_slash_username
2382
2383 Returns $domain/$username/
2384
2385 =cut
2386
2387 sub domain_slash_username {
2388   my $self = shift;
2389   $self->domain. '/'. $self->username. '/';
2390 }
2391
2392 =item virtual_maildir
2393
2394 Returns $domain/maildirs/$username/
2395
2396 =cut
2397
2398 sub virtual_maildir {
2399   my $self = shift;
2400   $self->domain. '/maildirs/'. $self->username. '/';
2401 }
2402
2403 =back
2404
2405 =head1 SUBROUTINES
2406
2407 =over 4
2408
2409 =item send_email
2410
2411 This is the FS::svc_acct job-queue-able version.  It still uses
2412 FS::Misc::send_email under-the-hood.
2413
2414 =cut
2415
2416 sub send_email {
2417   my %opt = @_;
2418
2419   eval "use FS::Misc qw(send_email)";
2420   die $@ if $@;
2421
2422   $opt{mimetype} ||= 'text/plain';
2423   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2424
2425   my $error = send_email(
2426     'from'         => $opt{from},
2427     'to'           => $opt{to},
2428     'subject'      => $opt{subject},
2429     'content-type' => $opt{mimetype},
2430     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2431   );
2432   die $error if $error;
2433 }
2434
2435 =item check_and_rebuild_fuzzyfiles
2436
2437 =cut
2438
2439 sub check_and_rebuild_fuzzyfiles {
2440   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2441   -e "$dir/svc_acct.username"
2442     or &rebuild_fuzzyfiles;
2443 }
2444
2445 =item rebuild_fuzzyfiles
2446
2447 =cut
2448
2449 sub rebuild_fuzzyfiles {
2450
2451   use Fcntl qw(:flock);
2452
2453   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2454
2455   #username
2456
2457   open(USERNAMELOCK,">>$dir/svc_acct.username")
2458     or die "can't open $dir/svc_acct.username: $!";
2459   flock(USERNAMELOCK,LOCK_EX)
2460     or die "can't lock $dir/svc_acct.username: $!";
2461
2462   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2463
2464   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2465     or die "can't open $dir/svc_acct.username.tmp: $!";
2466   print USERNAMECACHE join("\n", @all_username), "\n";
2467   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2468
2469   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2470   close USERNAMELOCK;
2471
2472 }
2473
2474 =item all_username
2475
2476 =cut
2477
2478 sub all_username {
2479   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2480   open(USERNAMECACHE,"<$dir/svc_acct.username")
2481     or die "can't open $dir/svc_acct.username: $!";
2482   my @array = map { chomp; $_; } <USERNAMECACHE>;
2483   close USERNAMECACHE;
2484   \@array;
2485 }
2486
2487 =item append_fuzzyfiles USERNAME
2488
2489 =cut
2490
2491 sub append_fuzzyfiles {
2492   my $username = shift;
2493
2494   &check_and_rebuild_fuzzyfiles;
2495
2496   use Fcntl qw(:flock);
2497
2498   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2499
2500   open(USERNAME,">>$dir/svc_acct.username")
2501     or die "can't open $dir/svc_acct.username: $!";
2502   flock(USERNAME,LOCK_EX)
2503     or die "can't lock $dir/svc_acct.username: $!";
2504
2505   print USERNAME "$username\n";
2506
2507   flock(USERNAME,LOCK_UN)
2508     or die "can't unlock $dir/svc_acct.username: $!";
2509   close USERNAME;
2510
2511   1;
2512 }
2513
2514
2515
2516 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2517
2518 =cut
2519
2520 sub radius_usergroup_selector {
2521   my $sel_groups = shift;
2522   my %sel_groups = map { $_=>1 } @$sel_groups;
2523
2524   my $selectname = shift || 'radius_usergroup';
2525
2526   my $dbh = dbh;
2527   my $sth = $dbh->prepare(
2528     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2529   ) or die $dbh->errstr;
2530   $sth->execute() or die $sth->errstr;
2531   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2532
2533   my $html = <<END;
2534     <SCRIPT>
2535     function ${selectname}_doadd(object) {
2536       var myvalue = object.${selectname}_add.value;
2537       var optionName = new Option(myvalue,myvalue,false,true);
2538       var length = object.$selectname.length;
2539       object.$selectname.options[length] = optionName;
2540       object.${selectname}_add.value = "";
2541     }
2542     </SCRIPT>
2543     <SELECT MULTIPLE NAME="$selectname">
2544 END
2545
2546   foreach my $group ( @all_groups ) {
2547     $html .= qq(<OPTION VALUE="$group");
2548     if ( $sel_groups{$group} ) {
2549       $html .= ' SELECTED';
2550       $sel_groups{$group} = 0;
2551     }
2552     $html .= ">$group</OPTION>\n";
2553   }
2554   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2555     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2556   };
2557   $html .= '</SELECT>';
2558
2559   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2560            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2561
2562   $html;
2563 }
2564
2565 =item reached_threshold
2566
2567 Performs some activities when svc_acct thresholds (such as number of seconds
2568 remaining) are reached.
2569
2570 =cut
2571
2572 sub reached_threshold {
2573   my %opt = @_;
2574
2575   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2576   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2577
2578   if ( $opt{'op'} eq '+' ){
2579     $svc_acct->setfield( $opt{'column'}.'_threshold',
2580                          int($svc_acct->getfield($opt{'column'})
2581                              * ( $conf->exists('svc_acct-usage_threshold')
2582                                  ? $conf->config('svc_acct-usage_threshold')/100
2583                                  : 0.80
2584                                )
2585                          )
2586                        );
2587     my $error = $svc_acct->replace;
2588     die $error if $error;
2589   }elsif ( $opt{'op'} eq '-' ){
2590
2591     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2592     return '' if ($threshold eq '' );
2593
2594     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2595     my $error = $svc_acct->replace;
2596     die $error if $error; # email next time, i guess
2597
2598     if ( $warning_template ) {
2599       eval "use FS::Misc qw(send_email)";
2600       die $@ if $@;
2601
2602       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
2603       my $cust_main = $cust_pkg->cust_main;
2604
2605       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2606                                $cust_main->invoicing_list,
2607                                ($opt{'to'} ? $opt{'to'} : ())
2608                    );
2609
2610       my $mimetype = $warning_mimetype;
2611       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2612
2613       my $body       =  $warning_template->fill_in( HASH => {
2614                         'custnum'   => $cust_main->custnum,
2615                         'username'  => $svc_acct->username,
2616                         'password'  => $svc_acct->_password,
2617                         'first'     => $cust_main->first,
2618                         'last'      => $cust_main->getfield('last'),
2619                         'pkg'       => $cust_pkg->part_pkg->pkg,
2620                         'column'    => $opt{'column'},
2621                         'amount'    => $opt{'column'} =~/bytes/
2622                                        ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2623                                        : $svc_acct->getfield($opt{'column'}),
2624                         'threshold' => $opt{'column'} =~/bytes/
2625                                        ? FS::UI::bytecount::display_bytecount($threshold)
2626                                        : $threshold,
2627                       } );
2628
2629
2630       my $error = send_email(
2631         'from'         => $warning_from,
2632         'to'           => $to,
2633         'subject'      => $warning_subject,
2634         'content-type' => $mimetype,
2635         'body'         => [ map "$_\n", split("\n", $body) ],
2636       );
2637       die $error if $error;
2638     }
2639   }else{
2640     die "unknown op: " . $opt{'op'};
2641   }
2642 }
2643
2644 =back
2645
2646 =head1 BUGS
2647
2648 The $recref stuff in sub check should be cleaned up.
2649
2650 The suspend, unsuspend and cancel methods update the database, but not the
2651 current object.  This is probably a bug as it's unexpected and
2652 counterintuitive.
2653
2654 radius_usergroup_selector?  putting web ui components in here?  they should
2655 probably live somewhere else...
2656
2657 insertion of RADIUS group stuff in insert could be done with child_objects now
2658 (would probably clean up export of them too)
2659
2660 =head1 SEE ALSO
2661
2662 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2663 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2664 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2665 L<freeside-queued>), L<FS::svc_acct_pop>,
2666 schema.html from the base documentation.
2667
2668 =cut
2669
2670 =item domain_select_hash %OPTIONS
2671
2672 Returns a hash SVCNUM => DOMAIN ...  representing the domains this customer
2673 may at present purchase.
2674
2675 Currently available options are: I<pkgnum> I<svcpart>
2676
2677 =cut
2678
2679 sub domain_select_hash {
2680   my ($self, %options) = @_;
2681   my %domains = ();
2682   my $part_svc;
2683   my $cust_pkg;
2684
2685   if (ref($self)) {
2686     $part_svc = $self->part_svc;
2687     $cust_pkg = $self->cust_svc->cust_pkg
2688       if $self->cust_svc;
2689   }
2690
2691   $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2692     if $options{'svcpart'};
2693
2694   $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2695     if $options{'pkgnum'};
2696
2697   if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2698                   || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2699     %domains = map { $_->svcnum => $_->domain }
2700                map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2701                split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2702   }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2703     %domains = map { $_->svcnum => $_->domain }
2704                map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2705                map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2706                qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2707   }else{
2708     %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2709   }
2710
2711   if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2712     my $svc_domain = qsearchs('svc_domain',
2713       { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2714     if ( $svc_domain ) {
2715       $domains{$svc_domain->svcnum}  = $svc_domain->domain;
2716     }else{
2717       warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2718            $part_svc->part_svc_column('domsvc')->columnvalue;
2719
2720     }
2721   }
2722
2723   (%domains);
2724 }
2725
2726 1;
2727