#!/usr/bin/perl
our
$VERSION
=
'0.01'
;
my
$o
= gopts(
'a:p'
);
my
$cfg
= _figureout_cfg();
my
$auth
= new CGI::Auth::Auto(
$cfg
) or
die
"CGI::Auth error"
;
_detect_prune();
sub
_detect_prune{
$o
->{p} or
return
;
print
"Pruning session file directory...\n"
;
print
$auth
->prune,
" stale session files deleted.\n"
;
exit
;
}
my
$option
;
do
{
show_info();
show_menu();
print
"Option: "
;
$option
= <STDIN>;
print
"\n"
;
if
(
$option
=~ /^a/i){
addprompt(
$auth
);
}
elsif
(
$option
=~ /^l/i){
print
"Users currently in the userbase:\n\n"
;
$auth
->listusers;
}
elsif
(
$option
=~ /^v/i) {
my
$un
;
print
"User name to view: "
;
$un
= <STDIN>;
chomp
$un
;
chomp
$un
;
$auth
->viewuser(
$un
);
}
elsif
(
$option
=~ /^d/i){
my
$un
;
print
"User name to delete: "
;
$un
= <STDIN>;
chomp
$un
;
chomp
$un
;
$auth
->deluser(
$un
);
}
elsif
(
$option
=~ /^p/i) {
print
"Pruning session file directory...\n"
;
print
$auth
->prune,
" stale session files deleted.\n"
;
}
print
"\n"
;
}
while
(
$option
!~ /^
q/i);
sub show_info {
printf "Authdir %s\nSessdir: %s\nUserfiledat: %s %s\n\n",
$auth->authdir, $auth->sessdir, $auth->userfile, (get_mode($auth->userfile) || '') ;
return;
}
# *Since* not a member of CGI::Auth, just pass it an auth object reference.
sub addprompt {
my $self = shift;
my @authfields = @{ $self->{authfields} };
print "Adding a new user.\n";
print scalar( @authfields ), " fields are needed: ", join( ', ', map $_->{display}, @authfields ), ".\n\n";
my $validchars = $self->{validchars};
my @fields;
FIELD: for my $f ( @authfields ) {
my $notice = ( $f->{hidden} && !$self->{md5pwd} ) ? '16 characters or less; ' : '';
print "Enter " . $f->{display} . "(${notice}Leave blank to cancel) : ";
my $data = <STDIN>;
# Untaint, and remove newlines.
$data =~ /
^(.*?)$/;
$data
= $1;
unless
(
$data
)
{
print
"Cancelled.\n"
;
return
0;
}
if
(
$data
=~ /([^
$validchars
])/ )
{
print
"Data entered contains an invalid character ($1).\n"
;
redo
FIELD;
}
push
@fields
,
$data
;
}
print
"Adding user '$fields[0]'.\n"
;
$auth
->adduser(
@fields
);
return
1;
}
sub
show_menu {
my
$menutext
=
<<MENU;
Acquisitions Database Authorization Manager
Select one of the following options (case insensitive):
A - Add a user
L - List users
V - View a user
D - Delete a user
P - Prune session files
Q - Quit
--------------------------------------------------------
MENU
print
$menutext
;
}
sub
_figureout_cfg {
scalar
@ARGV
or
die
(
"you must provide path to user.dat file, even if it does not exist yet"
);
my
$abs
=
$ARGV
[0]
or
die
(
'missing path to user.dat'
);
$abs
=~/^\// or
$abs
= cwd().
"/$abs"
;
$abs
=~/^(.+)\/+([^\/]+)$/ or
die
(
"cant match inside [$abs]"
);
my
$authdir
= $1;
my
$userfile
= $2;
my
$cfg
= {};
$cfg
->{-admin} = 1;
$cfg
->{-authdir} =
$authdir
;
$cfg
->{-userfile} =
$userfile
;
$cfg
->{-sessdir} =
$authdir
.
'/sess'
;
if
(-e
$abs
){
-f
$abs
or
die
(
"$abs should be a file not a dir"
);
}
unless
( -f
$abs
){
open
USERDAT,
'>'
,
$abs
and
close
USERDAT;
}
return
$cfg
;
}