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