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'), 1) {
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         $error ||= $self->overlimit($action);
1551         if ( $error ) {
1552           $dbh->rollback if $oldAutoCommit;
1553           return "Error replacing radius groups in export, ${op}: $error";
1554         }
1555       }
1556     }
1557   }
1558
1559   if ( $conf->exists("svc_acct-usage_$action")
1560        && &{$op2condition{$op}}($self, $column, $amount)    ) {
1561     #my $error = $self->$action();
1562     my $error = $self->cust_svc->cust_pkg->$action();
1563     $error ||= $self->overlimit($action);
1564     if ( $error ) {
1565       $dbh->rollback if $oldAutoCommit;
1566       return "Error ${action}ing: $error";
1567     }
1568   }
1569
1570   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1571     my $wqueue = new FS::queue {
1572       'svcnum' => $self->svcnum,
1573       'job'    => 'FS::svc_acct::reached_threshold',
1574     };
1575
1576     my $to = '';
1577     if ($op eq '-'){
1578       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1579     }
1580
1581     # x_threshold race
1582     my $error = $wqueue->insert(
1583       'svcnum' => $self->svcnum,
1584       'op'     => $op,
1585       'column' => $column,
1586       'to'     => $to,
1587     );
1588     if ( $error ) {
1589       $dbh->rollback if $oldAutoCommit;
1590       return "Error queuing threshold activity: $error";
1591     }
1592   }
1593
1594   warn "$me update successful; committing\n"
1595     if $DEBUG;
1596   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1597   '';
1598
1599 }
1600
1601 sub set_usage {
1602   my( $self, $valueref ) = @_;
1603
1604   warn "$me set_usage called for svcnum ". $self->svcnum.
1605        ' ('. $self->email. "): ".
1606        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1607     if $DEBUG;
1608
1609   local $SIG{HUP} = 'IGNORE';
1610   local $SIG{INT} = 'IGNORE';
1611   local $SIG{QUIT} = 'IGNORE';
1612   local $SIG{TERM} = 'IGNORE';
1613   local $SIG{TSTP} = 'IGNORE';
1614   local $SIG{PIPE} = 'IGNORE';
1615
1616   local $FS::svc_Common::noexport_hack = 1;
1617   my $oldAutoCommit = $FS::UID::AutoCommit;
1618   local $FS::UID::AutoCommit = 0;
1619   my $dbh = dbh;
1620
1621   my $reset = 0;
1622   my %handyhash = ();
1623   foreach my $field (keys %$valueref){
1624     $reset = 1 if $valueref->{$field};
1625     $self->setfield($field, $valueref->{$field});
1626     $self->setfield( $field.'_threshold',
1627                      int($self->getfield($field)
1628                          * ( $conf->exists('svc_acct-usage_threshold')
1629                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
1630                              : 0.20
1631                            )
1632                        )
1633                      );
1634     $handyhash{$field} = $self->getfield($field);
1635     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1636   }
1637   #my $error = $self->replace;   #NO! we avoid the call to ->check for
1638   #die $error if $error;         #services not explicity changed via the UI
1639
1640   my $sql = "UPDATE svc_acct SET " .
1641     join (',', map { "$_ =  ?" } (keys %handyhash) ).
1642     " WHERE svcnum = ?";
1643
1644   warn "$me $sql\n"
1645     if $DEBUG;
1646
1647   if (scalar(keys %handyhash)) {
1648     my $sth = $dbh->prepare( $sql )
1649       or die "Error preparing $sql: ". $dbh->errstr;
1650     my $rv = $sth->execute((grep{$_} values %handyhash), $self->svcnum);
1651     die "Error executing $sql: ". $sth->errstr
1652       unless defined($rv);
1653     die "Can't update usage for svcnum ". $self->svcnum
1654       if $rv == 0;
1655   }
1656
1657   if ( $reset ) {
1658     my $error = $self->overlimit('unsuspend');
1659
1660     foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1661       if ($part_export->option('overlimit_groups'), 1) {
1662         my $old = new FS::svc_acct $self->hashref;
1663         my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1664                        ($self, $part_export->option('overlimit_groups'));
1665         $old->usergroup( $groups );
1666         $error ||= $part_export->export_replace($self, $old);
1667       }
1668     }
1669
1670     if ( $conf->exists("svc_acct-usage_unsuspend")) {
1671       $error ||= $self->cust_svc->cust_pkg->unsuspend;
1672     }
1673     if ( $error ) {
1674       $dbh->rollback if $oldAutoCommit;
1675       return "Error unsuspending: $error";
1676     }
1677   }
1678
1679   warn "$me update successful; committing\n"
1680     if $DEBUG;
1681   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1682   '';
1683
1684 }
1685
1686
1687 =item recharge HASHREF
1688
1689   Increments usage columns by the amount specified in HASHREF as
1690   column=>amount pairs.
1691
1692 =cut
1693
1694 sub recharge {
1695   my ($self, $vhash) = @_;
1696
1697   if ( $DEBUG ) {
1698     warn "[$me] recharge called on $self: ". Dumper($self).
1699          "\nwith vhash: ". Dumper($vhash);
1700   }
1701
1702   my $oldAutoCommit = $FS::UID::AutoCommit;
1703   local $FS::UID::AutoCommit = 0;
1704   my $dbh = dbh;
1705   my $error = '';
1706
1707   foreach my $column (keys %$vhash){
1708     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1709   }
1710
1711   if ( $error ) {
1712     $dbh->rollback if $oldAutoCommit;
1713   }else{
1714     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1715   }
1716   return $error;
1717 }
1718
1719 =item is_rechargeable
1720
1721 Returns true if this svc_account can be "recharged" and false otherwise.
1722
1723 =cut
1724
1725 sub is_rechargable {
1726   my $self = shift;
1727   $self->seconds ne ''
1728     || $self->upbytes ne ''
1729     || $self->downbytes ne ''
1730     || $self->totalbytes ne '';
1731 }
1732
1733 =item seconds_since TIMESTAMP
1734
1735 Returns the number of seconds this account has been online since TIMESTAMP,
1736 according to the session monitor (see L<FS::Session>).
1737
1738 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1739 L<Time::Local> and L<Date::Parse> for conversion functions.
1740
1741 =cut
1742
1743 #note: POD here, implementation in FS::cust_svc
1744 sub seconds_since {
1745   my $self = shift;
1746   $self->cust_svc->seconds_since(@_);
1747 }
1748
1749 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1750
1751 Returns the numbers of seconds this account has been online between
1752 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1753 external SQL radacct table, specified via sqlradius export.  Sessions which
1754 started in the specified range but are still open are counted from session
1755 start to the end of the range (unless they are over 1 day old, in which case
1756 they are presumed missing their stop record and not counted).  Also, sessions
1757 which end in the range but started earlier are counted from the start of the
1758 range to session end.  Finally, sessions which start before the range but end
1759 after are counted for the entire range.
1760
1761 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1762 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1763 functions.
1764
1765 =cut
1766
1767 #note: POD here, implementation in FS::cust_svc
1768 sub seconds_since_sqlradacct {
1769   my $self = shift;
1770   $self->cust_svc->seconds_since_sqlradacct(@_);
1771 }
1772
1773 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1774
1775 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1776 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1777 TIMESTAMP_END (exclusive).
1778
1779 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1780 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1781 functions.
1782
1783 =cut
1784
1785 #note: POD here, implementation in FS::cust_svc
1786 sub attribute_since_sqlradacct {
1787   my $self = shift;
1788   $self->cust_svc->attribute_since_sqlradacct(@_);
1789 }
1790
1791 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1792
1793 Returns an array of hash references of this customers login history for the
1794 given time range.  (document this better)
1795
1796 =cut
1797
1798 sub get_session_history {
1799   my $self = shift;
1800   $self->cust_svc->get_session_history(@_);
1801 }
1802
1803 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1804
1805 =cut
1806
1807 sub get_cdrs {
1808   my($self, $start, $end, %opt ) = @_;
1809
1810   my $did = $self->username; #yup
1811
1812   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1813
1814   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1815
1816   #SELECT $for_update * FROM cdr
1817   #  WHERE calldate >= $start #need a conversion
1818   #    AND calldate <  $end   #ditto
1819   #    AND (    charged_party = "$did"
1820   #          OR charged_party = "$prefix$did" #if length($prefix);
1821   #          OR ( ( charged_party IS NULL OR charged_party = '' )
1822   #               AND
1823   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1824   #             )
1825   #        )
1826   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
1827
1828   my $charged_or_src;
1829   if ( length($prefix) ) {
1830     $charged_or_src =
1831       " AND (    charged_party = '$did'
1832               OR charged_party = '$prefix$did'
1833               OR ( ( charged_party IS NULL OR charged_party = '' )
1834                    AND
1835                    ( src = '$did' OR src = '$prefix$did' )
1836                  )
1837             )
1838       ";
1839   } else {
1840     $charged_or_src =
1841       " AND (    charged_party = '$did'
1842               OR ( ( charged_party IS NULL OR charged_party = '' )
1843                    AND
1844                    src = '$did'
1845                  )
1846             )
1847       ";
1848
1849   }
1850
1851   qsearch(
1852     'select'    => "$for_update *",
1853     'table'     => 'cdr',
1854     'hashref'   => {
1855                      #( freesidestatus IS NULL OR freesidestatus = '' )
1856                      'freesidestatus' => '',
1857                    },
1858     'extra_sql' => $charged_or_src,
1859
1860   );
1861
1862 }
1863
1864 =item radius_groups
1865
1866 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1867
1868 =cut
1869
1870 sub radius_groups {
1871   my $self = shift;
1872   if ( $self->usergroup ) {
1873     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
1874       unless ref($self->usergroup) eq 'ARRAY';
1875     #when provisioning records, export callback runs in svc_Common.pm before
1876     #radius_usergroup records can be inserted...
1877     @{$self->usergroup};
1878   } else {
1879     map { $_->groupname }
1880       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1881   }
1882 }
1883
1884 =item clone_suspended
1885
1886 Constructor used by FS::part_export::_export_suspend fallback.  Document
1887 better.
1888
1889 =cut
1890
1891 sub clone_suspended {
1892   my $self = shift;
1893   my %hash = $self->hash;
1894   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1895   new FS::svc_acct \%hash;
1896 }
1897
1898 =item clone_kludge_unsuspend
1899
1900 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
1901 better.
1902
1903 =cut
1904
1905 sub clone_kludge_unsuspend {
1906   my $self = shift;
1907   my %hash = $self->hash;
1908   $hash{_password} = '';
1909   new FS::svc_acct \%hash;
1910 }
1911
1912 =item check_password
1913
1914 Checks the supplied password against the (possibly encrypted) password in the
1915 database.  Returns true for a successful authentication, false for no match.
1916
1917 Currently supported encryptions are: classic DES crypt() and MD5
1918
1919 =cut
1920
1921 sub check_password {
1922   my($self, $check_password) = @_;
1923
1924   #remove old-style SUSPENDED kludge, they should be allowed to login to
1925   #self-service and pay up
1926   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1927
1928   #eventually should check a "password-encoding" field
1929   if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1930     return 0;
1931   } elsif ( length($password) < 13 ) { #plaintext
1932     $check_password eq $password;
1933   } elsif ( length($password) == 13 ) { #traditional DES crypt
1934     crypt($check_password, $password) eq $password;
1935   } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1936     unix_md5_crypt($check_password, $password) eq $password;
1937   } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1938     warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1939          $self->svcnum. "\n";
1940     0;
1941   } else {
1942     warn "Can't check password: Unrecognized encryption for svcnum ".
1943          $self->svcnum. "\n";
1944     0;
1945   }
1946
1947 }
1948
1949 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1950
1951 Returns an encrypted password, either by passing through an encrypted password
1952 in the database or by encrypting a plaintext password from the database.
1953
1954 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1955 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1956 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1957 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
1958 encryption type is only used if the password is not already encrypted in the
1959 database.
1960
1961 =cut
1962
1963 sub crypt_password {
1964   my $self = shift;
1965   #eventually should check a "password-encoding" field
1966   if ( length($self->_password) == 13
1967        || $self->_password =~ /^\$(1|2a?)\$/
1968        || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
1969      )
1970   {
1971     $self->_password;
1972   } else {
1973     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1974     if ( $encryption eq 'crypt' ) {
1975       crypt(
1976         $self->_password,
1977         $saltset[int(rand(64))].$saltset[int(rand(64))]
1978       );
1979     } elsif ( $encryption eq 'md5' ) {
1980       unix_md5_crypt( $self->_password );
1981     } elsif ( $encryption eq 'blowfish' ) {
1982       croak "unknown encryption method $encryption";
1983     } else {
1984       croak "unknown encryption method $encryption";
1985     }
1986   }
1987 }
1988
1989 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
1990
1991 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
1992 describing the format, for example, "{CRYPT}94pAVyK/4oIBk" or
1993 "{PLAIN-MD5}5426824942db4253f87a1009fd5d2d4f".
1994
1995 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
1996 to work the same as the B</crypt_password> method.
1997
1998 =cut
1999
2000 sub ldap_password {
2001   my $self = shift;
2002   #eventually should check a "password-encoding" field
2003   if ( length($self->_password) == 13 ) { #crypt
2004     return '{CRYPT}'. $self->_password;
2005   } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2006     return '{MD5}'. $1;
2007   } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2008     die "Blowfish encryption not supported in this context, svcnum ".
2009         $self->svcnum. "\n";
2010   } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2011     return '{SSHA}'. $1;
2012   } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2013     return '{NS-MTA-MD5}'. $1;
2014   } else { #plaintext
2015     return '{PLAIN}'. $self->_password;
2016     #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2017     #if ( $encryption eq 'crypt' ) {
2018     #  return '{CRYPT}'. crypt(
2019     #    $self->_password,
2020     #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2021     #  );
2022     #} elsif ( $encryption eq 'md5' ) {
2023     #  unix_md5_crypt( $self->_password );
2024     #} elsif ( $encryption eq 'blowfish' ) {
2025     #  croak "unknown encryption method $encryption";
2026     #} else {
2027     #  croak "unknown encryption method $encryption";
2028     #}
2029   }
2030 }
2031
2032 =item domain_slash_username
2033
2034 Returns $domain/$username/
2035
2036 =cut
2037
2038 sub domain_slash_username {
2039   my $self = shift;
2040   $self->domain. '/'. $self->username. '/';
2041 }
2042
2043 =item virtual_maildir
2044
2045 Returns $domain/maildirs/$username/
2046
2047 =cut
2048
2049 sub virtual_maildir {
2050   my $self = shift;
2051   $self->domain. '/maildirs/'. $self->username. '/';
2052 }
2053
2054 =back
2055
2056 =head1 SUBROUTINES
2057
2058 =over 4
2059
2060 =item send_email
2061
2062 This is the FS::svc_acct job-queue-able version.  It still uses
2063 FS::Misc::send_email under-the-hood.
2064
2065 =cut
2066
2067 sub send_email {
2068   my %opt = @_;
2069
2070   eval "use FS::Misc qw(send_email)";
2071   die $@ if $@;
2072
2073   $opt{mimetype} ||= 'text/plain';
2074   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2075
2076   my $error = send_email(
2077     'from'         => $opt{from},
2078     'to'           => $opt{to},
2079     'subject'      => $opt{subject},
2080     'content-type' => $opt{mimetype},
2081     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2082   );
2083   die $error if $error;
2084 }
2085
2086 =item check_and_rebuild_fuzzyfiles
2087
2088 =cut
2089
2090 sub check_and_rebuild_fuzzyfiles {
2091   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2092   -e "$dir/svc_acct.username"
2093     or &rebuild_fuzzyfiles;
2094 }
2095
2096 =item rebuild_fuzzyfiles
2097
2098 =cut
2099
2100 sub rebuild_fuzzyfiles {
2101
2102   use Fcntl qw(:flock);
2103
2104   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2105
2106   #username
2107
2108   open(USERNAMELOCK,">>$dir/svc_acct.username")
2109     or die "can't open $dir/svc_acct.username: $!";
2110   flock(USERNAMELOCK,LOCK_EX)
2111     or die "can't lock $dir/svc_acct.username: $!";
2112
2113   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2114
2115   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2116     or die "can't open $dir/svc_acct.username.tmp: $!";
2117   print USERNAMECACHE join("\n", @all_username), "\n";
2118   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2119
2120   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2121   close USERNAMELOCK;
2122
2123 }
2124
2125 =item all_username
2126
2127 =cut
2128
2129 sub all_username {
2130   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2131   open(USERNAMECACHE,"<$dir/svc_acct.username")
2132     or die "can't open $dir/svc_acct.username: $!";
2133   my @array = map { chomp; $_; } <USERNAMECACHE>;
2134   close USERNAMECACHE;
2135   \@array;
2136 }
2137
2138 =item append_fuzzyfiles USERNAME
2139
2140 =cut
2141
2142 sub append_fuzzyfiles {
2143   my $username = shift;
2144
2145   &check_and_rebuild_fuzzyfiles;
2146
2147   use Fcntl qw(:flock);
2148
2149   my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2150
2151   open(USERNAME,">>$dir/svc_acct.username")
2152     or die "can't open $dir/svc_acct.username: $!";
2153   flock(USERNAME,LOCK_EX)
2154     or die "can't lock $dir/svc_acct.username: $!";
2155
2156   print USERNAME "$username\n";
2157
2158   flock(USERNAME,LOCK_UN)
2159     or die "can't unlock $dir/svc_acct.username: $!";
2160   close USERNAME;
2161
2162   1;
2163 }
2164
2165
2166
2167 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2168
2169 =cut
2170
2171 sub radius_usergroup_selector {
2172   my $sel_groups = shift;
2173   my %sel_groups = map { $_=>1 } @$sel_groups;
2174
2175   my $selectname = shift || 'radius_usergroup';
2176
2177   my $dbh = dbh;
2178   my $sth = $dbh->prepare(
2179     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2180   ) or die $dbh->errstr;
2181   $sth->execute() or die $sth->errstr;
2182   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2183
2184   my $html = <<END;
2185     <SCRIPT>
2186     function ${selectname}_doadd(object) {
2187       var myvalue = object.${selectname}_add.value;
2188       var optionName = new Option(myvalue,myvalue,false,true);
2189       var length = object.$selectname.length;
2190       object.$selectname.options[length] = optionName;
2191       object.${selectname}_add.value = "";
2192     }
2193     </SCRIPT>
2194     <SELECT MULTIPLE NAME="$selectname">
2195 END
2196
2197   foreach my $group ( @all_groups ) {
2198     $html .= qq(<OPTION VALUE="$group");
2199     if ( $sel_groups{$group} ) {
2200       $html .= ' SELECTED';
2201       $sel_groups{$group} = 0;
2202     }
2203     $html .= ">$group</OPTION>\n";
2204   }
2205   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2206     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2207   };
2208   $html .= '</SELECT>';
2209
2210   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2211            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2212
2213   $html;
2214 }
2215
2216 =item reached_threshold
2217
2218 Performs some activities when svc_acct thresholds (such as number of seconds
2219 remaining) are reached.
2220
2221 =cut
2222
2223 sub reached_threshold {
2224   my %opt = @_;
2225
2226   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2227   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2228
2229   if ( $opt{'op'} eq '+' ){
2230     $svc_acct->setfield( $opt{'column'}.'_threshold',
2231                          int($svc_acct->getfield($opt{'column'})
2232                              * ( $conf->exists('svc_acct-usage_threshold')
2233                                  ? $conf->config('svc_acct-usage_threshold')/100
2234                                  : 0.80
2235                                )
2236                          )
2237                        );
2238     my $error = $svc_acct->replace;
2239     die $error if $error;
2240   }elsif ( $opt{'op'} eq '-' ){
2241
2242     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2243     return '' if ($threshold eq '' );
2244
2245     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2246     my $error = $svc_acct->replace;
2247     die $error if $error; # email next time, i guess
2248
2249     if ( $warning_template ) {
2250       eval "use FS::Misc qw(send_email)";
2251       die $@ if $@;
2252
2253       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
2254       my $cust_main = $cust_pkg->cust_main;
2255
2256       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2257                                $cust_main->invoicing_list,
2258                                ($opt{'to'} ? $opt{'to'} : ())
2259                    );
2260
2261       my $mimetype = $warning_mimetype;
2262       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2263
2264       my $body       =  $warning_template->fill_in( HASH => {
2265                         'custnum'   => $cust_main->custnum,
2266                         'username'  => $svc_acct->username,
2267                         'password'  => $svc_acct->_password,
2268                         'first'     => $cust_main->first,
2269                         'last'      => $cust_main->getfield('last'),
2270                         'pkg'       => $cust_pkg->part_pkg->pkg,
2271                         'column'    => $opt{'column'},
2272                         'amount'    => $svc_acct->getfield($opt{'column'}),
2273                         'threshold' => $threshold,
2274                       } );
2275
2276
2277       my $error = send_email(
2278         'from'         => $warning_from,
2279         'to'           => $to,
2280         'subject'      => $warning_subject,
2281         'content-type' => $mimetype,
2282         'body'         => [ map "$_\n", split("\n", $body) ],
2283       );
2284       die $error if $error;
2285     }
2286   }else{
2287     die "unknown op: " . $opt{'op'};
2288   }
2289 }
2290
2291 =back
2292
2293 =head1 BUGS
2294
2295 The $recref stuff in sub check should be cleaned up.
2296
2297 The suspend, unsuspend and cancel methods update the database, but not the
2298 current object.  This is probably a bug as it's unexpected and
2299 counterintuitive.
2300
2301 radius_usergroup_selector?  putting web ui components in here?  they should
2302 probably live somewhere else...
2303
2304 insertion of RADIUS group stuff in insert could be done with child_objects now
2305 (would probably clean up export of them too)
2306
2307 =head1 SEE ALSO
2308
2309 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2310 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2311 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2312 L<freeside-queued>), L<FS::svc_acct_pop>,
2313 schema.html from the base documentation.
2314
2315 =cut
2316
2317 1;
2318