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