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