+
+}
+
+
+sub _password_encryption {
+ my $self = shift;
+ my $encoding = lc($self->_password_encoding);
+ return if !$encoding;
+ return 'plain' if $encoding eq 'plain';
+ if($encoding eq 'crypt') {
+ my $pass = $self->_password;
+ $pass =~ s/^\*SUSPENDED\* //;
+ $pass =~ s/^!!?//;
+ return 'md5' if $pass =~ /^\$1\$/;
+ #return 'blowfish' if $self->_password =~ /^\$2\$/;
+ return 'des' if length($pass) == 13;
+ return;
+ }
+ if($encoding eq 'ldap') {
+ uc($self->_password) =~ /^\{([\w-]+)\}/;
+ return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
+ return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
+ return 'md5' if $1 eq 'MD5';
+ return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
+
+ return;
+ }
+ return;
+}
+
+sub get_cleartext_password {
+ my $self = shift;
+ if($self->_password_encryption eq 'plain') {
+ if($self->_password_encoding eq 'ldap') {
+ $self->_password =~ /\{\w+\}(.*)$/;
+ return $1;
+ }
+ else {
+ return $self->_password;
+ }
+ }
+ return;
+}
+
+
+=item set_password
+
+Set the cleartext password for the account. If _password_encoding is set, the
+new password will be encoded according to the existing method (including
+encryption mode, if it can be determined). Otherwise,
+config('default-password-encoding') is used.
+
+If no password is supplied (or a zero-length password when minimum password length
+is >0), one will be generated randomly.
+
+=cut
+
+sub set_password {
+ my( $self, $pass ) = ( shift, shift );
+
+ warn "[$me] set_password (to $pass) called on $self: ". Dumper($self)
+ if $DEBUG;
+
+ my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
+ FS::Msgcat::_gettext('illegal_password_characters').
+ ": ". $pass;
+
+ my( $encoding, $encryption ) = ('', '');
+
+ if ( $self->_password_encoding ) {
+ $encoding = $self->_password_encoding;
+ # identify existing encryption method, try to use it.
+ $encryption = $self->_password_encryption;
+ if (!$encryption) {
+ # use the system default
+ undef $encoding;
+ }
+ }
+
+ if ( !$encoding ) {
+ # set encoding to system default
+ ($encoding, $encryption) =
+ split(/-/, lc($conf->config('default-password-encoding')));
+ $encoding ||= 'legacy';
+ $self->_password_encoding($encoding);
+ }
+
+ if ( $encoding eq 'legacy' ) {
+
+ # The legacy behavior from check():
+ # If the password is blank, randomize it and set encoding to 'plain'.
+ if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
+ $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
+ $self->_password_encoding('plain');
+ } else {
+ # Prefix + valid-length password
+ if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
+ $pass = $1.$3;
+ $self->_password_encoding('plain');
+ # Prefix + crypt string
+ } elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
+ $pass = $1.$3;
+ $self->_password_encoding('crypt');
+ # Various disabled crypt passwords
+ } elsif ( $pass eq '*' || $pass eq '!' || $pass eq '!!' ) {
+ $self->_password_encoding('crypt');
+ } else {
+ return $failure;
+ }
+ }
+
+ $self->_password($pass);
+ return;
+
+ }
+
+ return $failure
+ if $passwordmin && length($pass) < $passwordmin
+ or $passwordmax && length($pass) > $passwordmax;
+
+ if ( $encoding eq 'crypt' ) {
+ if ($encryption eq 'md5') {
+ $pass = unix_md5_crypt($pass);
+ } elsif ($encryption eq 'des') {
+ $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
+ }
+
+ } elsif ( $encoding eq 'ldap' ) {
+ if ($encryption eq 'md5') {
+ $pass = md5_base64($pass);
+ } elsif ($encryption eq 'sha1') {
+ $pass = sha1_base64($pass);
+ } elsif ($encryption eq 'crypt') {
+ $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
+ }
+ # else $encryption eq 'plain', do nothing
+ $pass .= '=' x (4 - length($pass) % 4) #properly padded base64
+ if $encryption eq 'md5' || $encryption eq 'sha1';
+ $pass = '{'.uc($encryption).'}'.$pass;
+ }
+ # else encoding eq 'plain'
+
+ $self->_password($pass);
+ return;
+}
+
+=item _check_system
+
+Internal function to check the username against the list of system usernames
+from the I<system_usernames> configuration value. Returns true if the username
+is listed on the system username list.
+
+=cut
+
+sub _check_system {
+ my $self = shift;
+ scalar( grep { $self->username eq $_ || $self->email eq $_ }
+ $conf->config('system_usernames')
+ );
+}
+
+=item _check_duplicate
+
+Internal method to check for duplicates usernames, username@domain pairs and
+uids.
+
+If the I<global_unique-username> configuration value is set to B<username> or
+B<username@domain>, enforces global username or username@domain uniqueness.
+
+In all cases, check for duplicate uids and usernames or username@domain pairs
+per export and with identical I<svcpart> values.
+
+=cut
+
+sub _check_duplicate {
+ my $self = shift;
+
+ my $global_unique = $conf->config('global_unique-username') || 'none';
+ return '' if $global_unique eq 'disabled';
+
+ $self->lock_table;
+
+ my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
+ unless ( $part_svc ) {
+ return 'unknown svcpart '. $self->svcpart;
+ }
+
+ my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
+ qsearch( 'svc_acct', { 'username' => $self->username } );
+ return gettext('username_in_use')
+ if $global_unique eq 'username' && @dup_user;
+
+ my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
+ qsearch( 'svc_acct', { 'username' => $self->username,
+ 'domsvc' => $self->domsvc } );
+ return gettext('username_in_use')
+ if $global_unique eq 'username@domain' && @dup_userdomain;
+
+ my @dup_uid;
+ if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
+ && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
+ @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
+ qsearch( 'svc_acct', { 'uid' => $self->uid } );
+ } else {
+ @dup_uid = ();
+ }
+
+ if ( @dup_user || @dup_userdomain || @dup_uid ) {
+ my $exports = FS::part_export::export_info('svc_acct');
+ my %conflict_user_svcpart;
+ my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
+
+ foreach my $part_export ( $part_svc->part_export ) {
+
+ #this will catch to the same exact export
+ my @svcparts = map { $_->svcpart } $part_export->export_svc;
+
+ #this will catch to exports w/same exporthost+type ???
+ #my @other_part_export = qsearch('part_export', {
+ # 'machine' => $part_export->machine,
+ # 'exporttype' => $part_export->exporttype,
+ #} );
+ #foreach my $other_part_export ( @other_part_export ) {
+ # push @svcparts, map { $_->svcpart }
+ # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
+ #}
+
+ #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
+ #silly kludge to avoid uninitialized value errors
+ my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
+ ? $exports->{$part_export->exporttype}{'nodomain'}
+ : '';
+ if ( $nodomain =~ /^Y/i ) {
+ $conflict_user_svcpart{$_} = $part_export->exportnum
+ foreach @svcparts;
+ } else {
+ $conflict_userdomain_svcpart{$_} = $part_export->exportnum
+ foreach @svcparts;
+ }
+ }
+
+ foreach my $dup_user ( @dup_user ) {
+ my $dup_svcpart = $dup_user->cust_svc->svcpart;
+ if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
+ return "duplicate username ". $self->username.
+ ": conflicts with svcnum ". $dup_user->svcnum.
+ " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
+ }
+ }
+
+ foreach my $dup_userdomain ( @dup_userdomain ) {
+ my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
+ if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
+ return "duplicate username\@domain ". $self->email.
+ ": conflicts with svcnum ". $dup_userdomain->svcnum.
+ " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
+ }
+ }
+
+ foreach my $dup_uid ( @dup_uid ) {
+ my $dup_svcpart = $dup_uid->cust_svc->svcpart;
+ if ( exists($conflict_user_svcpart{$dup_svcpart})
+ || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
+ return "duplicate uid ". $self->uid.
+ ": conflicts with svcnum ". $dup_uid->svcnum.
+ " via exportnum ".
+ ( $conflict_user_svcpart{$dup_svcpart}
+ || $conflict_userdomain_svcpart{$dup_svcpart} );
+ }
+ }
+
+ }
+
+ return '';
+
+}
+
+=item radius
+
+Depriciated, use radius_reply instead.
+
+=cut
+
+sub radius {
+ carp "FS::svc_acct::radius depriciated, use radius_reply";
+ $_[0]->radius_reply;
+}
+
+=item radius_reply
+
+Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
+reply attributes of this record.
+
+Note that this is now the preferred method for reading RADIUS attributes -
+accessing the columns directly is discouraged, as the column names are
+expected to change in the future.
+
+=cut
+
+sub radius_reply {
+ my $self = shift;
+
+ return %{ $self->{'radius_reply'} }
+ if exists $self->{'radius_reply'};
+
+ my %reply =
+ map {
+ /^(radius_(.*))$/;
+ my($column, $attrib) = ($1, $2);
+ #$attrib =~ s/_/\-/g;
+ ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
+ } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
+
+ if ( $self->slipip && $self->slipip ne '0e0' ) {
+ $reply{$radius_ip} = $self->slipip;
+ }
+
+ if ( $self->seconds !~ /^$/ ) {
+ $reply{'Session-Timeout'} = $self->seconds;
+ }
+
+ if ( $conf->exists('radius-chillispot-max') ) {
+ #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
+
+ #hmm. just because sqlradius.pm says so?
+ my %whatis = (
+ 'input' => 'up',
+ 'output' => 'down',
+ 'total' => 'total',
+ );
+
+ foreach my $what (qw( input output total )) {
+ my $is = $whatis{$what}.'bytes';
+ if ( $self->$is() =~ /\d/ ) {
+ my $big = new Math::BigInt $self->$is();
+ $big = new Math::BigInt '0' if $big->is_neg();
+ my $att = "Chillispot-Max-\u$what";
+ $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
+ $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
+ }
+ }
+
+ }
+
+ %reply;
+}
+
+=item radius_check
+
+Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
+check attributes of this record.
+
+Note that this is now the preferred method for reading RADIUS attributes -
+accessing the columns directly is discouraged, as the column names are
+expected to change in the future.
+
+=cut
+
+sub radius_check {
+ my $self = shift;
+
+ return %{ $self->{'radius_check'} }
+ if exists $self->{'radius_check'};
+
+ my %check =
+ map {
+ /^(rc_(.*))$/;
+ my($column, $attrib) = ($1, $2);
+ #$attrib =~ s/_/\-/g;
+ ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
+ } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
+
+
+ my($pw_attrib, $password) = $self->radius_password;
+ $check{$pw_attrib} = $password;
+
+ my $cust_svc = $self->cust_svc;
+ if ( $cust_svc ) {
+ my $cust_pkg = $cust_svc->cust_pkg;
+ if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
+ $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
+ }
+ } else {
+ warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
+ "; can't set Expiration\n"
+ unless $cust_svc;
+ }
+
+ %check;
+
+}
+
+=item radius_password
+
+Returns a key/value pair containing the RADIUS attribute name and value
+for the password.
+
+=cut
+
+sub radius_password {
+ my $self = shift;
+
+ my $pw_attrib;
+ if ( $self->_password_encoding eq 'ldap' ) {
+ $pw_attrib = 'Password-With-Header';
+ } elsif ( $self->_password_encoding eq 'crypt' ) {
+ $pw_attrib = 'Crypt-Password';
+ } elsif ( $self->_password_encoding eq 'plain' ) {
+ $pw_attrib = $radius_password;
+ } else {
+ $pw_attrib = length($self->_password) <= 12
+ ? $radius_password
+ : 'Crypt-Password';
+ }
+
+ ($pw_attrib, $self->_password);
+
+}
+
+=item snapshot
+
+This method instructs the object to "snapshot" or freeze RADIUS check and
+reply attributes to the current values.
+
+=cut
+
+#bah, my english is too broken this morning
+#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
+#the FS::cust_pkg's replace method to trigger the correct export updates when
+#package dates change)
+
+sub snapshot {
+ my $self = shift;
+
+ $self->{$_} = { $self->$_() }
+ foreach qw( radius_reply radius_check );
+