File Coverage

lib/HTTPD/RealmManager.pm
Criterion Covered Total %
statement 214 313 68.3
branch 76 178 42.7
condition 9 22 40.9
subroutine 24 34 70.5
pod 19 28 67.8
total 342 575 59.4


line stmt bran cond sub pod time code
1             package HTTPD::RealmManager;
2 5     5   6845 use strict;
  5         59  
  5         196  
3              
4             require Exporter;
5 5     5   28 use vars qw(@ISA @EXPORT $VERSION $ERROR);
  5         23  
  5         467  
6              
7             @ISA = 'Exporter';
8             @EXPORT = qw(rearrange);
9             $ERROR = '';
10             $VERSION = 1.33;
11              
12 5     5   29 use Carp;
  5         25  
  5         17553  
13             require HTTPD::Realm;
14              
15             sub open {
16 2     2 1 27 my $class = shift;
17 2         13 my ($realm,$config,$rest) = rearrange([ 'REALM',['CONFIG_FILE','CONFIG']],@_);
18 2 50       51 croak "Must provide the path to a config file" unless -r $config;
19 2         24 my $realms = new HTTPD::Realm(-config_file=>$config,%$rest);
20 2 50       52 return undef unless $realms;
21 2         9 my $r = $realms->realm($realm);
22 2 50       9 return undef unless $r;
23 2         17 return $realms->dbm(-realm=>$r,%$rest);
24             }
25              
26             sub new {
27 3     3 1 6 my $class = shift;
28 3         15 my ($realm,$mode,$writable,$server) = rearrange([ 'REALM', 'MODE', ['WRITE','WRITABLE'], 'SERVER' ],@_);
29 3 50 33     12 croak "Must provide a valid realm object" unless $realm && ref($realm);
30 3   50     21 my $self = {
31             'realm'=>$realm,
32             'mode'=>$mode || 0644,
33             'writable'=>$writable,
34             'server'=>$server,
35             };
36 3         8 bless $self,$class;
37 3 50       9 return undef unless $self->open_passwd;
38 3 50       13 return undef unless $self->open_group;
39 3         34 return $self;
40             }
41              
42             sub open_passwd {
43 4     4 0 7 my $self = shift;
44 4         17 my $realm = $self->{realm};
45              
46             # Create the right kind of HTTPD::UserAdmin and HTTPD::GroupAdmin objects.
47 4         5 my %params;
48 4         14 $params{DB} = $realm->userdb;
49 4         16 $params{Encrypt} = $realm->crypt;
50 4         12 $params{Server} = $self->{server};
51 4 100       12 $params{Flags} = $self->{writable} ? 'rwc' : 'r';
52 4         8 $params{Mode} = $self->{mode};
53 4         7 $params{Locking} = $self->{writable};
54 4 50       10 if ($realm->crypt() =~ /MD5/) {
55 0         0 $params{Encrypt} = 'MD5';
56 0         0 $self->{digest}++;
57             }
58              
59 4         13 my $userType = $realm->usertype;
60             CASE: {
61 4 50       5 do { $params{DBType} = 'Text'; next; } if $userType=~/text|file/i;
  4         50  
  4         8  
  4         6  
62 0 0       0 do { $params{DBType} = 'DBM';
  0         0  
63 0         0 $params{DBMF} = "\U$userType\E";
64 0 0       0 $params{DBMF} = 'NDBM' if $params{DBMF} eq 'DBM';
65 0         0 next; } if $userType =~ /^(NDBM|GDBM|DB|DBM|SDBM|ODBM)$/;
66 0 0       0 do {
67 0         0 my $p = $realm->SQLdata;
68 0         0 $params{DB} = $p->{database};
69 0 0       0 $params{Host} = $p->{host} eq 'localhost' ? '' : $p->{host};
70 0         0 $params{DBType} = 'SQL';
71 0         0 $params{Driver} = $realm->driver;
72             #
73             # do what Lincoln didn't:
74 0         0 $params{User} = $p->{dblogin};
75 0         0 $params{Auth} = $p->{dbpassword};
76 0         0 $params{DEBUG} = 0;
77             #
78 0         0 $params{UserTable} = $p->{usertable};
79 0         0 $params{NameField} = $p->{userfield};
80 0         0 $params{PasswordField} = $p->{passwdfield};
81 0         0 next; } if $userType=~/sql/i;
82             }
83              
84 3     3   1295 my $return = eval <<'END';
  3         95  
  3         26  
  4         443  
85             use HTTPD::UserAdmin 1.50;
86             $self->{userDB} = new HTTPD::UserAdmin(%params);
87             END
88             ;
89 4 50       24 $ERROR = $@ unless $return;
90 4         20 return $return;
91             }
92              
93             sub errstr {
94 0     0 1 0 return $ERROR;
95             }
96              
97             sub open_group {
98 4     4 0 8 my $self = shift;
99 4         11 my $realm = $self->{realm};
100 4 50       23 return 1 unless $realm->groupdb;
101              
102 4         6 my %params;
103 4         12 $params{DB} = $realm->groupdb;
104 4         14 $params{Server} = $self->{server};
105 4 100       27 $params{Flags} = $self->{writable} ? 'rwc' : 'r';
106 4         10 $params{Mode} = $self->{mode};
107 4         16 $params{Locking} = $self->{writable};
108 4         15 my $groupType = $realm->grouptype;
109              
110             CASE: {
111 4 50       5 do { $params{DBType} = 'Text'; next } if $groupType=~/text|file/i;
  4         41  
  4         8  
  4         8  
112 0 0       0 do {
113 0         0 $params{DBType} = 'DBM';
114 0         0 $params{DBMF} = "\U$groupType\E";
115 0 0       0 $params{DBMF} = 'NDBM' if $params{DBMF} eq 'DBM';
116 0         0 next } if $groupType =~ /^(NDBM|GDBM|DB|DBM|SDBM|ODBM)$/;
117 0 0       0 do {
118 0         0 my $p = $realm->SQLdata;
119 0         0 $params{DB} = $p->{database};
120 0 0       0 $params{Host} = $p->{host} eq 'localhost' ? '' : $p->{host};
121 0         0 $params{DBType} = 'SQL';
122 0         0 $params{Driver} = $realm->driver;
123             #
124             # do what Lincoln didn't:
125 0         0 $params{User} = $p->{dblogin};
126 0         0 $params{Auth} = $p->{dbpassword};
127 0         0 $params{DEBUG} = 0;
128             #
129 0         0 $params{GroupTable} = $p->{grouptable};
130 0   0     0 $params{NameField} = $p->{groupuserfield} || $p->{userfield};
131 0         0 $params{GroupField} = $p->{groupfield};
132 0         0 $params{UserTable} = $p->{usertable}; # needed for obscure reasons
133 0         0 next; } if $groupType=~/sql/i;
134             }
135 2     2   1097 my $return = eval<<'END';
  2         62  
  2         22  
  4         235  
136             use HTTPD::GroupAdmin 1.50;
137             $self->{groupDB} = new HTTPD::GroupAdmin(%params);
138             END
139             ;
140 4 50       25 $ERROR = $@ unless $return;
141 4         106 return $return;
142             }
143              
144              
145             sub users {
146 0     0 1 0 my $self = shift;
147 0         0 return $self->{userDB}->list();
148             }
149              
150             # Return true if a user is in a particular group
151             sub match_group {
152 1     1 1 2 my $self = shift;
153 1         6 my ($user,$group) = rearrange([['USER','NAME'],['GROUP','GRP']],@_);
154 1 50       4 croak "Must provide a user name" unless $user;
155 1 50       3 croak "Must provide a group name" unless $group;
156 1 50       4 return undef unless $self->{groupDB};
157              
158             # Slightly different if we're using a DBM file.
159             # Result of inconsistencies in HTTPD::GroupAdmin
160 1         1 my %users;
161 1         5 grep ($users{$_}++,$self->{groupDB}->list($group));
162 1         5 return $users{$user};
163             }
164              
165             sub open_writable {
166 6     6 0 8 my $self = shift;
167 6 100       24 return 1 if $self->{writable};
168 1         3 $self->{writable}++;
169 1 50       2 if ($self->{userDB}) {
170 1         4 $self->{userDB}->commit();
171 1         4 $self->{userDB}->close();
172 1 50       3 unless ($self->open_passwd()) {
173 0         0 $ERROR = "Unable to open user file for writing";
174 0         0 return undef;
175             }
176             }
177 1 50       3 if ($self->{groupDB}) {
178 1         5 $self->{groupDB}->commit();
179 1         4 $self->{groupDB}->close();
180 1 50       2 unless ( $self->open_group() ) {
181 0         0 $ERROR = "Unable to open group file for writing";
182 0         0 return undef;
183             }
184             }
185 1         3 1;
186             }
187              
188             sub set_passwd {
189 3     3 1 5 my $self = shift;
190 3         19 my ($user,$passwd,$otherfields) = rearrange([[qw(USER NAME)],[qw(PASSWORD PASSWD)],[qw(OTHER GCOS FIELDS VALUES)] ],@_);
191 3 50       11 croak "Must provide a user ID" unless $user;
192 3 50 33     9 croak "Must provide a password or field values" unless $passwd || $otherfields;
193 3 50       8 return undef unless $self->{userDB};
194              
195             # reopen if necessary
196 3 50       8 return undef unless $self->open_writable();
197              
198             #special passwords for the digest method
199 3 50 33     17 $passwd = "$user:$self->{realm}:$passwd" if $passwd && $self->{digest};
200              
201 3         4 my @other = ();
202 3         4 my $result;
203 3 50       5 if (defined($otherfields)) {
204 3 50       10 @other = ref($otherfields) eq 'ARRAY' ? @$otherfields : ($otherfields) ;
205             }
206              
207 3 50       31 if ($self->{userDB}->exists($user)) {
208              
209             # nasty hack here to avoid problems in the way that UserAdmin does its
210             # updates (first it deletes, then it adds!)
211 0         0 my($crypt) = '';
212 0 0       0 unless ($passwd) {
213 0         0 ($crypt,$self->{userDB}->{ENCRYPT}) = ($self->{userDB}->{ENCRYPT},'none');
214 0         0 $passwd = $self->passwd($user);
215             }
216              
217 0 0       0 @other = $self->get_fields($user) unless @other;
218 0         0 ($result,$ERROR) = $self->{userDB}->update($user,$passwd,@other);
219 0 0       0 $self->{userDB}->{ENCRYPT} = $crypt if $crypt;
220 0 0       0 return $result unless $result;
221            
222             } else {
223              
224 3         18 ($result,$ERROR) = $self->{userDB}->add($user,$passwd,@other);
225 3 50       8 return $result unless $result;
226              
227             }
228 3         20 ($result,$ERROR) = $self->{userDB}->commit();
229 3         17 return $result;
230             }
231              
232 0     0 1 0 sub set_password { &set_passwd; }
233              
234             sub set_fields {
235 0     0 1 0 my $self = shift;
236 0         0 my ($user,$fields) = rearrange([[qw(USER NAME)],[qw(OTHER GCOS FIELD FIELDS VALUES)] ],@_);
237 0 0       0 croak "Must provide a user ID" unless $user;
238 0 0       0 croak "Must provide field values" unless $fields;
239 0         0 my $current = $self->get_fields(-user=>$user);
240 0         0 foreach (keys %$fields) {
241 0         0 $current->{$_} = $fields->{$_};
242             }
243 0         0 return $self->set_passwd(-user=>$user,-fields=>$current);
244             }
245              
246             # return true if passwords match
247             sub match_passwd {
248 2     2 1 3 my $self = shift;
249 2         26 my ($user,$passwd) = rearrange([[qw(USER NAME)],[qw(PASSWD PASSWORD)]],@_);
250 2 50       6 croak "Must provide a user ID" unless $user;
251 2 50       6 croak "Must provide a password" unless $passwd;
252 2 50       7 return undef unless $self->{userDB}->exists($user);
253 2 50       7 $passwd = "$user:$self->{realm}:$passwd" if $self->{digest};
254 2         6 my $stored_passwd = $self->{userDB}->password($user);
255 2 50       7 if ($self->{userDB}->{ENCRYPT} eq 'crypt') {
256 2         82 return crypt($passwd,$stored_passwd) eq $stored_passwd;
257             } else {
258 0         0 return $self->{userDB}->encrypt($passwd) eq $stored_passwd;
259             }
260             }
261              
262             # shortcut for match_passwd
263 2     2 1 6 sub match { &match_passwd; }
264              
265             sub passwd {
266 1     1 1 3 my $self = shift;
267 1         7 my ($user,$passwd) = rearrange([[qw(USER NAME)],[qw(PASSWORD PASSWD)]],@_);
268 1 50       4 croak "Must provide a user ID" unless $user;
269 1 50       3 if ($passwd) { return $self->match_passwd('-user'=>$user,'-passwd'=>$passwd) };
  0         0  
270 1 50       6 return undef unless $self->{userDB}->exists($user);
271 1         12 my (@pw) = split(/:/,$self->{userDB}->password($user));
272 1 50       4 return $pw[1] if $self->{digest};
273 1         4 return $pw[0];
274             }
275              
276 0     0 1 0 sub password { &passwd; }
277              
278             sub delete_user {
279 0     0 1 0 my $self = shift;
280 0         0 my ($user) = rearrange([[qw(USER NAME)]],@_);
281 0 0       0 croak "Must provide a user ID" unless $user;
282 0 0       0 return undef unless $self->open_writable();
283              
284 0 0       0 $self->{userDB}->delete($user) if $self->{userDB};
285 0 0       0 return unless $self->{groupDB};
286              
287 0         0 my $group;
288 0         0 foreach $group ($self->{groupDB}->list) {
289 0         0 $self->{groupDB}->delete($user,$group);
290             }
291 0         0 my $result;
292 0         0 ($result,$ERROR) = $self->{groupDB}->commit();
293 0 0       0 return $result unless $result;
294 0         0 ($result,$ERROR) = $self->{userDB}->commit();
295 0         0 return $result;
296             }
297              
298             # With one argument returns the groups that the user is in.
299             # With two arguments returns true if user is in the group
300             sub group {
301 5     5 1 7 my $self = shift;
302 5         22 my ($user,$group) = rearrange([[qw(USER NAME)],[qw(GROUP GRP)]],@_);
303 5 50       14 croak "Must provide a user ID" unless $user;
304 5 100       8 if ($group) { return $self->match_group('-user'=>$user,'-group'=>$group) };
  1         5  
305 4 50       11 return () unless my $db = $self->{groupDB};
306              
307             # Shortcut to avoid doing and undoing unnecessary work.
308 4 50       11 if (ref($db)=~/DBM::apache/) {
309             # check for Apache's weird combined user/group database format
310 0 0       0 return $self->{groupDB}->{DB} eq $self->{userDB}->{DB}
311             ? split(',',(split(':',$db->{'_HASH'}->{$user}))[1])
312             : split(',',$db->{'_HASH'}->{$user});
313             }
314              
315 4         4 my ($g,%groups);
316 4         19 foreach $g ($self->{groupDB}->list) {
317 9         8 my %user;
318 9         24 grep($user{$_}++,$self->{groupDB}->list($g));
319 9 100       32 $groups{$g}++ if $user{$user};
320             }
321 4         20 return keys %groups;
322             }
323              
324             sub groups {
325 3     3 1 4 my $self = shift;
326 3 50       9 return () unless $self->{groupDB};
327 3         8 return $self->{groupDB}->list();
328             }
329              
330             sub members {
331 10     10 0 11 my $self = shift;
332 10         27 my ($group) = rearrange([[qw(GROUP GRP)]],@_);
333 10 50       28 $group || croak "Must provide a group name";
334 10 50       20 return () unless $self->{groupDB};
335 10         27 return $self->{groupDB}->list($group);
336             }
337              
338             sub set_group {
339 3     3 1 4 my $self = shift;
340 3         14 my ($user,$groups) = rearrange([[qw(USER NAME)],[qw(GROUP GRP)]],@_);
341 3 50       10 croak "Must provide a user ID" unless $user;
342 3         3 my $db;
343              
344             # reopen if necessary
345 3 50       9 return undef unless $self->open_writable();
346              
347 3 50       9 return unless $db = $self->{groupDB};
348 3 50       12 my (@groups) = ref($groups) ? @$groups : ($groups);
349              
350             # Shortcut to avoid doing and undoing work.
351 3 50       10 if (ref($db)=~/DBM::apache/) {
352 0         0 $db->{'_HASH'}->{$user}=join(',',@groups);
353 0         0 $self->remove_dangling_groups();
354 0         0 return 1;
355             }
356              
357             # otherwise we do it the "correct" way
358 3         3 my (%current,%new);
359 3         11 grep ($current{$_}++,$self->group($user));
360 3         11 grep ($new{$_}++,@groups);
361              
362 3         27 my (@to_remove) = grep (!$new{$_},keys %current);
363 3         11 my (@to_add) = grep (!$current{$_},keys %new);
364 3         7 foreach (@to_remove) {
365 0         0 $db->delete($user,$_);
366             }
367 3         4 foreach (@to_add) {
368 6         21 $db->add($user,$_);
369             }
370              
371 3         10 $self->remove_dangling_groups();
372 3         5 my $result;
373 3         14 ($result,$ERROR) = $db->commit();
374 3         23 return $result;
375             }
376              
377             sub delete_group {
378 0     0 1 0 my $self = shift;
379 0         0 my ($group) = rearrange([[qw(GROUP GRP)]],@_);
380 0 0       0 $group || croak "Must provide a group name";
381 0 0       0 return 1 unless $self->{groupDB};
382 0 0       0 return undef unless $self->open_writable();
383              
384 0         0 $self->{groupDB}->remove($group);
385 0         0 my $result;
386 0         0 ($result,$ERROR) = $self->{groupDB}->commit();
387 0         0 return $result;
388             }
389              
390             sub remove_dangling_groups {
391 3     3 0 4 my $self = shift;
392 3         13 my $grp;
393 3         9 foreach $grp ($self->groups) {
394 9 50       14 next unless $grp;
395 9 50       26 $self->delete_group($grp)
396             unless $self->members('-group'=>$grp);
397             }
398             }
399              
400             # Fetch field names from a SQL database.
401             # Only those fields that are returned by fields() are accessible.
402             # The return value is an associative array in which the keys are the
403             # field names and the values are the field types (s=string, i=integer, f=real).
404             sub fields {
405 1     1 0 2 my $realm = shift->{realm};
406 1         2 my $fields;
407 1 50       5 return () unless $fields = $realm->fields;
408 1         4 my @f = split(/\s+/,$fields);
409 1         2 my %f;
410 1         2 foreach (@f) {
411 4         9 my($name,$type) = split(':',$_,2);
412 4   100     33 $f{$name} = $type || 's'; # string by default
413             }
414 1         9 return %f;
415             }
416              
417             # Fetch the named fields from an SQL database.
418             # Input is a user ID and a reference to a list of field names. All fields will be
419             # returned if no list specified.
420             # The return value is a hash of the fields, or a reference to the hash in a scalar
421             # context.
422             sub get_fields {
423 1     1 1 2 my $self = shift;
424 1         6 my ($user,$fields) = rearrange([[qw(USER NAME)],[qw(FIELDS FIELD VALUE VALUES)]],@_);
425 1 50       5 croak "Must provide a user ID" unless $user;
426              
427 1         4 my (%ok) = $self->fields;
428 1         2 my (@fields);
429 1 50       3 if (defined($fields)) {
430 0         0 @fields = grep ($ok{$_},@$fields);
431             } else {
432 1         3 @fields = keys %ok;
433             }
434 1         19 $self->{userDB}->fetch($user,@fields);
435             }
436              
437             sub error {
438 0     0 0 0 return $ERROR;
439             }
440              
441             sub close {
442 1     1 1 2 my $self = shift;
443 1 50       4 do { $self->{userDB}->commit; $self->{userDB}->close() } if $self->{userDB};
  1         4  
  1         16  
444 1 50       12 do { $self->{groupDB}->commit; $self->{groupDB}->close() } if $self->{groupDB};
  1         14  
  1         10  
445              
446             }
447              
448             sub DESTROY {
449 0     0   0 my $self = shift;
450 0         0 $self->close;
451             }
452              
453             # -------- exported utility routine ----------
454             sub rearrange {
455 45     45 0 111 my($order,@param) = @_;
456 45 100       96 return () unless @param;
457              
458 43 100 66     245 return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-');
459              
460 32         39 my $i;
461 32         93 for ($i=0;$i<@param;$i+=2) {
462 59         176 $param[$i]=~s/^\-//; # get rid of initial - if present
463 59         167 $param[$i]=~tr/a-z/A-Z/; # parameters are upper case
464             }
465              
466             # make sure param has even number of elements
467 32 50 33     222 push(@param,'') if ((@param) && ($#param % 2 == 0));
468              
469 32         115 my(%param) = @param; # convert into associative array
470 32         35 my(@return_array);
471              
472 32         85 local($^W) = 0;
473 32         69 my($key)='';
474 32         49 foreach $key (@$order) {
475 63         60 my($value);
476 63 100       118 if (ref($key) eq 'ARRAY') {
477 45         63 foreach (@$key) {
478 99 100       170 last if defined($value);
479 66         81 $value = $param{$_};
480 66         144 delete $param{$_};
481             }
482             } else {
483 18         25 $value = $param{$key};
484 18         29 delete $param{$key};
485             }
486 63         126 push(@return_array,$value);
487             }
488 32 100       78 push (@return_array,{%param}) if %param;
489 32         128 return (@return_array);
490             }
491              
492             sub realm {
493 0     0 0   return shift->{realm};
494             }
495              
496             1;
497              
498              
499             __END__