FS/FS/svc_acct.pm

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