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


line stmt bran cond sub pod time code
1             # $Id: UserAdmin.pm,v 1.1.1.1 2004/06/28 19:24:27 veselosky Exp $
2             package CGI::Builder::Auth::UserAdmin;
3 5     5   2458 use CGI::Builder::Auth::AdminBase ();
  5         13  
  5         120  
4 5     5   44 use Carp ();
  5         97  
  5         97  
5 5     5   26 use strict;
  5         8  
  5         186  
6 5     5   26 use vars qw($VERSION @ISA);
  5         9  
  5         7555  
7             @ISA = qw(CGI::Builder::Auth::AdminBase);
8             $VERSION = 1.51;
9              
10             sub delete {
11 4     4 1 183 my($self, $user) = @_;
12 4         63 my $rc = 1;
13 4         12 delete($self->{'_HASH'}{$user});
14 4 50       14 $self->{'_HASH'}{$user} and $rc = 0;
15 4         18 $rc;
16             }
17              
18             sub suspend {
19 1     1 1 57 my($self, $user) = @_;
20 1 50       26 $self->{'_HASH'}->{$user} = "!".$self->{'_HASH'}->{$user}
21             if $self->{'_HASH'}->{$user} !~ m/^!/;
22 1 50       6 return 0 unless $self->{'_HASH'}->{$user} =~ m/^!/;
23 1         6 return 1;
24             }
25              
26             sub unsuspend {
27 1     1 1 57 my($self, $user) = @_;
28 1         26 $self->{'_HASH'}->{$user} =~ s/^!//;
29 1 50       7 return 0 unless $self->{'_HASH'}->{$user} !~ m/^!/;
30 1         5 return 1;
31             }
32              
33             sub list {
34 6     6 1 205 keys %{$_[0]->{'_HASH'}};
  6         19  
35             }
36              
37             sub exists {
38 54     54 1 1113 my($self, $name) = @_;
39 54 100       638 return 0 unless defined $self->{'_HASH'}{$name};
40 35         289 return $self->{'_HASH'}{$name};
41             }
42              
43             sub db {
44 22     22 1 41 my($self, $file) = @_;
45 22         44 my $old = $self->{'DB'};
46 22 50       58 return $old unless $file;
47 22 50       93 if($self->{'_HASH'}) {
48 0         0 $self->DESTROY;
49             }
50              
51 22         36 $self->{'DB'} = $file;
52              
53             #return unless $self->{NAME};
54 22 50       115 $self->lock || Carp::croak();
55 22         122 $self->_tie('_HASH', $self->{DB});
56 22         54 $old;
57             }
58              
59             sub group {
60 0     0 1 0 my($self) = shift;
61 0         0 $self->load('CGI::Builder::Auth::GroupAdmin');
62 0         0 my %attr = %{$self};
  0         0  
63 0         0 foreach(qw(DB _HASH)) {
64 0         0 delete $attr{$_}; #just incase, everything else should be OK
65             }
66 0         0 return new CGI::Builder::Auth::GroupAdmin (%attr, @_);
67             }
68              
69             sub update {
70 0     0 1 0 my($self, $username, $passwd, @fields) = @_;
71 0 0       0 return (0, "User '$username' does not exist") unless $self->exists($username);
72 0         0 my ($old_encr, $bool);
73 0 0       0 if (!defined $passwd) {
74 0         0 $bool = 1;
75 0         0 $passwd = $self->password($username);
76 0         0 $old_encr = $self->{ENCRYPT};
77 0         0 $self->{ENCRYPT} = 'none';
78             }
79 0         0 $self->delete($username);
80 0         0 $self->add($username, $passwd, @fields);
81 0 0       0 $self->{ENCRYPT} = $old_encr if $bool;
82 0         0 1;
83             }
84              
85             sub convert {
86 0     0 1 0 my($self) = shift;
87 0         0 my $class = $self->baseclass(2); #hmm
88 0         0 my $new = $class->new(@_);
89 0         0 foreach($self->list) {
90 0         0 $new->add($_, $self->password($_), 1);
91             }
92 0         0 $new;
93             }
94              
95             sub password {
96 8     8 1 196 my $self = shift;
97 8         55 my $val = $self->exists(@_);
98 8         64 my($x,$y,$z) = split(':',$val);
99 8 0       26 return defined($z) ? join(':',$x,$y,$z) : join(':',$x,$y)
    50          
100             if $self->{ENCRYPT} eq 'MD5';
101 8         27 return $x;
102             }
103              
104             # from Apache's dbmmanage:
105             # if $newstyle is 1, then use new style salt (starts with '_' and contains
106             # four bytes of iteration count and four bytes of salt). Otherwise, just use
107             # the traditional two-byte salt.
108             # see the man page on your system to decide if you have a newer crypt() lib.
109             # I believe that 4.4BSD derived systems do (at least BSD/OS 2.0 does).
110             # The new style crypt() allows up to 20 characters of the password to be
111             # significant rather than only 8.
112              
113             #my %NewStyle = map $_,1, qw(bsd/os-2.0);
114              
115             sub encrypt {
116 9     9 0 35 my($self) = shift;
117 9         18 my $newstyle = defined $_[1]; # || defined $NewStyle{ join("-",@Config{qw(osname osvers)}) };
118 9         18 my($passwd) = "";
119 9   50     28 my($scheme) = $self->{ENCRYPT} || "crypt";
120             # not quite sure where we're at risk here...
121             # $_[0] =~ /^[^<>;|]+$/ or Carp::croak("Bad password name"); $_[0] = $&;
122 9 50       25 if($scheme eq "crypt") {
    0          
    0          
    0          
123 9         26 $passwd = crypt($_[0], salt($newstyle));
124             }
125             elsif ($scheme eq "MD5") {
126             #I know, this isn't really "encryption",
127             #since you can't decrypt it, oh well...
128 0 0       0 unless (defined $self->{'_MD5'}) {
129 0         0 require Digest::MD5;
130 0         0 $self->{'_MD5'} = new Digest::MD5;
131             }
132 0         0 my($username,$realm,$pass) = split(":", $_[0]);
133              
134 0         0 $self->{'_MD5'}->add(join(":", $username, $realm, $pass));
135 0         0 $passwd = join(":", $realm, $self->{'_MD5'}->hexdigest());
136 0         0 $self->{'_MD5'}->reset;
137             } elsif ($scheme eq "SHA") {
138 0         0 require Digest::SHA1;
139 0         0 $passwd = '{SHA}' . Digest::SHA1::sha1_base64(shift) .'=';
140             } elsif ($scheme eq 'none') {
141 0         0 return $_[0];
142             } else {
143 0         0 Carp::croak("unknown encryption method '$_'");
144             }
145 9         37 return $passwd;
146             }
147              
148             sub salt {
149 9     9 0 21 my($newstyle) = @_;
150 9 50 33     59 return defined($newstyle) && $newstyle ?
151             join('', "_", randchar(1), "a..", randchar(4)) : randchar(2);
152             }
153              
154             my(@saltset) = (qw(. /), 0..9, "A".."Z", "a".."z");
155              
156             sub randchar {
157 9     9 0 25 local($^W) = 0; #we get a bogus warning here
158 9         16 my($count) = @_;
159 9         13 my $str = "";
160 9         224 $str .= $saltset[rand(@saltset)] while $count--;
161 9         2570 $str;
162             }
163              
164 0     0     sub DESTROY {
165             }
166              
167             #These should work fine with the _generic classes
168             my %Support = (apache => [qw(DBM Text SQL)],
169             ncsa => [qw(DBM Text)],
170             );
171              
172             CGI::Builder::Auth::UserAdmin->support(%Support);
173              
174             1;
175              
176             __END__