Hello,
Nearly all my work has been on virtual servers and recently our
hosting company (iserver) began to support mod_perl on their
freebsd servers ... so other than one time in the past I have
not had the opportunity to write code for mod_perl (except on
our intranet where it has been for personal use). As this code
will be going out for public use I feel more responsiblity. I'm
still in a situation of 'not knowing what I don't know'. I
would really, really appreciate criticisms (with suggestion for
improvement) for the following code. I would have used some of
the modules that seem to do what this does but I did not
like/understand them and, as you can imagine, the client wants
this to work asap. Thanks.
#!/usr/local/bin/perl5 -w
$|++;
use strict;
use Apache::Request();
use Apache::Cookie();
use DBISUPPORT;
use SERMON_HTML;
use vars qw($r $debug);
$r = Apache->request;
my $q= Apache::Request->new($r, POST_MAX => 25);
my $html = SERMON_HTML->new();
$debug = 0;
print_headers(1) if $debug;
my $level = '';
my $u = $q->param('u') || '';
my $p = $q->param('p') || '';
$level = verify_user() if (!$u && !$p);
if($level) {
print_headers();
print $html->graceful_snippets($level);
print qq|Level $level<hr>|;
}else {
my $user_level = &db_lookup($u,$p);
if(!$user_level) {
print_headers();
print $html->graceful_snippets('generic_header');
print $html->graceful_snippets('login');
print $html->graceful_snippets('footer');
}else {
print_headers(1,$user_level);
print $html->graceful_snippets($user_level);
print qq|Level $user_level<hr>|;
}
}
######################################################
## BEGIN SUBS
##
sub print_headers {
my $send_cookie = shift || 0;
my $nivel = shift || 0;
$r->content_type("text/html");
if($send_cookie && $nivel > 0) {
$r->headers_out->add("Set-Cookie" =>qq|nivel=$nivel|);
}
$r->send_http_header();
}
##
sub verify_user {
my %headers_in = $r->headers_in;
my $cookie = $headers_in{'Cookie'};
my(@bites) = split /;/,$cookie;
my $n = '';
my $v = '';
for(@bites) {
($n,$v) = split /=/;
$n =~ s/^\s+//;
if($n eq 'nivel') {
return $v;
}
}
return undef;
}
##
sub db_lookup {
my($username,$password) = @_;
my $dbi= DBISUPPORT->new('this_cgi'=>'/cgi-
bin/login.pl','database'=>'xxxx','username'=>'xxxx','password'=>'
xxxx');
my $table = 'members';
my $sql = qq|SELECT username,level,password FROM $table WHERE
username = '$username' AND password = '$password'|;
my $dbu = '';
my $dbg = '';
my $dbp = '';
($dbu,$dbg,$dbp)= $dbi->{'db'}->selectrow_array( qq{ $sql });
$dbi->{'db'}->disconnect();
if($dbu && $dbg && $dbp) {
return $dbg;
}else {
return undef;
}
}
##
---------------------------
"Reality is that which, when you stop believing in it, doesn't go
away".
-- Philip K. Dick
