File Coverage

blib/lib/CGI/Builder/Auth/UserAdmin.pm

Criterion	Covered	Total	%
statement	57	95	60.0
branch	12	38	31.5
condition	2	5	40.0
subroutine	14	18	77.7
pod	10	13	76.9
total	95	169	56.2

# $Id: UserAdmin.pm,v 1.1.1.1 2004/06/28 19:24:27 veselosky Exp $
package CGI::Builder::Auth::UserAdmin;
use CGI::Builder::Auth::AdminBase ();
use Carp ();
use strict;
use vars qw($VERSION @ISA);
@ISA = qw(CGI::Builder::Auth::AdminBase);
$VERSION = 1.51;

sub delete {
    my($self, $user) = @_;
    my $rc = 1;
    delete($self->{'_HASH'}{$user});
    $self->{'_HASH'}{$user} and $rc = 0;
    $rc;
}

sub suspend {
    my($self, $user) = @_;
    $self->{'_HASH'}->{$user} = "!".$self->{'_HASH'}->{$user}
      if $self->{'_HASH'}->{$user} !~ m/^!/;
    return 0 unless $self->{'_HASH'}->{$user} =~ m/^!/;
    return 1;
}

sub unsuspend {
    my($self, $user) = @_;
    $self->{'_HASH'}->{$user} =~ s/^!//;
    return 0 unless $self->{'_HASH'}->{$user} !~ m/^!/;
    return 1;
}

sub list {
    keys %{$_[0]->{'_HASH'}};
}

sub exists {
    my($self, $name) = @_;
    return 0 unless defined $self->{'_HASH'}{$name};
    return $self->{'_HASH'}{$name};
}

sub db {
    my($self, $file) = @_;
    my $old = $self->{'DB'};
    return $old unless $file;
    if($self->{'_HASH'}) {
	$self->DESTROY;
    }

    $self->{'DB'} = $file;

    #return unless $self->{NAME};
    $self->lock || Carp::croak();
    $self->_tie('_HASH', $self->{DB});
    $old;
}

sub group {
    my($self) = shift;
    $self->load('CGI::Builder::Auth::GroupAdmin');
    my %attr = %{$self};
    foreach(qw(DB _HASH)) {
	delete $attr{$_}; #just incase, everything else should be OK
    }
    return new CGI::Builder::Auth::GroupAdmin (%attr, @_);
}

sub update {
    my($self, $username, $passwd, @fields) = @_;
    return (0, "User '$username' does not exist") unless $self->exists($username);
    my ($old_encr, $bool);
    if (!defined $passwd) {
	$bool = 1;
	$passwd = $self->password($username);
	$old_encr = $self->{ENCRYPT};
	$self->{ENCRYPT} = 'none';
    }
    $self->delete($username);
    $self->add($username, $passwd, @fields);
    $self->{ENCRYPT} = $old_encr if $bool;
    1;
}

sub convert {
    my($self) = shift;
    my $class = $self->baseclass(2); #hmm
    my $new = $class->new(@_);
    foreach($self->list) {
	$new->add($_, $self->password($_), 1);
    }
    $new;
}

sub password {
    my $self = shift;
    my $val = $self->exists(@_);
    my($x,$y,$z) = split(':',$val);
    return defined($z) ? join(':',$x,$y,$z) : join(':',$x,$y)
	if $self->{ENCRYPT} eq 'MD5';
    return $x;
}

# from Apache's dbmmanage:
# if $newstyle is 1, then use new style salt (starts with '_' and contains
# four bytes of iteration count and four bytes of salt).  Otherwise, just use
# the traditional two-byte salt.
# see the man page on your system to decide if you have a newer crypt() lib.
# I believe that 4.4BSD derived systems do (at least BSD/OS 2.0 does).
# The new style crypt() allows up to 20 characters of the password to be
# significant rather than only 8.

#my %NewStyle = map $_,1, qw(bsd/os-2.0);

sub encrypt {
    my($self) = shift;
    my $newstyle = defined $_[1]; # || defined $NewStyle{ join("-",@Config{qw(osname osvers)}) };
    my($passwd) = "";
    my($scheme) = $self->{ENCRYPT} || "crypt";
    # not quite sure where we're at risk here...
    # $_[0] =~ /^[^<>;|]+$/ or Carp::croak("Bad password name"); $_[0] = $&;
    if($scheme eq "crypt") {
	$passwd = crypt($_[0], salt($newstyle));
    }
    elsif ($scheme eq "MD5") {
	#I know, this isn't really "encryption",
	#since you can't decrypt it, oh well...
	unless (defined $self->{'_MD5'}) {
	    require Digest::MD5;
	    $self->{'_MD5'} = new Digest::MD5;
	}
	my($username,$realm,$pass) = split(":", $_[0]);

	$self->{'_MD5'}->add(join(":", $username, $realm, $pass));
	$passwd = join(":", $realm, $self->{'_MD5'}->hexdigest());
	$self->{'_MD5'}->reset;
    } elsif ($scheme eq "SHA") {
	require Digest::SHA1;
	$passwd = '{SHA}' . Digest::SHA1::sha1_base64(shift) .'=';
    } elsif ($scheme eq 'none') {
	return $_[0];
    } else {
	Carp::croak("unknown encryption method '$_'");
    }
    return $passwd;
}

sub salt {
    my($newstyle) = @_;
    return defined($newstyle) && $newstyle ?
	join('', "_", randchar(1), "a..", randchar(4)) : randchar(2);
}

my(@saltset) = (qw(. /), 0..9, "A".."Z", "a".."z");

sub randchar {
  local($^W) = 0; #we get a bogus warning here
  my($count) = @_;
  my $str = "";
  $str .= $saltset[rand(@saltset)] while $count--;
  $str;
}

sub DESTROY {
}

#These should work fine with the _generic classes
my %Support = (apache =>   [qw(DBM Text SQL)],
	       ncsa   =>   [qw(DBM Text)],
	       );

CGI::Builder::Auth::UserAdmin->support(%Support);

1;

__END__