wip, perl warnings

diff --git a/CGI/Auth/Hybrid.pm b/CGI/Auth/Hybrid.pm
new file mode 120000 (symlink)
index 0000000..a8427d3
--- /dev/null
+++ b/CGI/Auth/Hybrid.pm
@@ -0,0 +1 @@
+../../cgi-auth-hybrid.pm
\ No newline at end of file

diff --git a/cgi-auth-hybrid.pm b/cgi-auth-hybrid.pm
index ec44c7a52816469be2e90d18a5892b835a31ec7f..f22083a94b3714fa3b0d16baac0278eb13075144 100644 (file)
--- a/cgi-auth-hybrid.pm
+++ b/cgi-auth-hybrid.pm
@@ -56,7 +56,7 @@ sub flatten_params ($) {
 #---------- default callbacks ----------
 
 sub has_a_param ($$) {
-    my ($c,$cn) = @_;
+    my ($c,$r,$cn) = @_;
     foreach my $pn (@{ $r->{S}{$cn} }) {
        return 1 if $r->_cm('get_param',$pn);
     }
@@ -64,7 +64,7 @@ sub has_a_param ($$) {
 }
 
 sub get_params ($$) {
-    my ($c) = @_;
+    my ($c,$r) = @_;
     my %p;
     foreach my $name ($c->param()) {
        $p{$name} = [ $c->param($name) ];
@@ -78,16 +78,6 @@ sub get_cookie_domain ($$$) {
     return $uri->host();
 }
 
-sub construct_cookie ($$$) {
-    my ($r, $cookv) = @_;
-    return $r->{Cgi}->cookie(-name => $r->{S}{cookie_name},
-                             -value => $cookv,
-                             -path => $r->{S}{cookie_path},
-                             -domain => $r->_ch('get_cookie_domain'),
-                             -expires => '+'.$r->{S}{login_timeout}.'s',
-                             -secure => $r->{S}{encrypted_only});
-}
-
 sub login_ok_password ($$) {
     my ($c, $r) = @_;
     my $username_params = $r->{S}{username_param_names};
@@ -171,7 +161,7 @@ sub new_verifier {
            promise_check_mutate => 0,
            get_param => sub { $_[0]->param($_[2]) },
            get_params => sub { $_[1]->get_params() },
-           get_cookie => sub { $_[0]->cookie($s->{S}{cookie_name}) },
+           get_cookie => sub { $_[0]->cookie($_[1]->{S}{cookie_name}) },
            get_method => sub { $_[0]->request_method() },
            get_url => sub { $_[0]->url(); },
             is_login => sub { defined $_[1]->_rp('password_param_name') },
@@ -195,8 +185,8 @@ sub new_verifier {
     };
     my ($k,$v);
     while (($k,$v,@_) = @_) {
-       die "unknown setting $k" unless exists $s->{S}{$k};
-       $s->{S}{$k} = $v;
+       die "unknown setting $k" unless exists $verifier->{S}{$k};
+       $verifier->{S}{$k} = $v;
     }
     bless $verifier, $class;
     $verifier->_dbopen();
@@ -209,13 +199,14 @@ sub _dbopen ($) {
     return $dbh if $dbh; 
 
     $v->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=$v->{S}{assocdb_path}";
+    my $dsn = $v->{S}{assocdb_dsn};
 
     my $u = umask 077;
-    $dbh = DBI->connect($v->{S}{assocdb_dsn}, $v->{S}{assocdb_user}, 
+    $dbh = DBI->connect($dsn, $v->{S}{assocdb_user}, 
                         $v->{S}{assocdb_password}, { 
                             AutoCommit => 0, RaiseError => 1,
                         });
-    die "${assocdb_dsn} $! ?" unless $dbh;
+    die "$dsn $! ?" unless $dbh;
     $v->{Dbh} = $dbh;
 
     $dbh->do("BEGIN");
@@ -270,6 +261,16 @@ sub _rp ($$@) {
 sub _gt ($$) { my ($r, $t) = @_; return $r->_ch('gettext',$t); }
 sub _print ($$) { my ($r, @t) = @_; return $r->_ch('print', join '', @t); }
 
+sub construct_cookie ($$$) {
+    my ($r, $cookv) = @_;
+    return $r->{Cgi}->cookie(-name => $r->{S}{cookie_name},
+                             -value => $cookv,
+                             -path => $r->{S}{cookie_path},
+                             -domain => $r->_ch('get_cookie_domain'),
+                             -expires => '+'.$r->{S}{login_timeout}.'s',
+                             -secure => $r->{S}{encrypted_only});
+}
+
 # pages/param-sets are
 #   n normal non-mutating page
 #   r retrieval of information for JS, non-mutating
@@ -483,6 +484,7 @@ sub _chain_params ($) {
     my ($r) = @_;
     my %p = %{ $r->_ch('get_params') };
     foreach my $pncn (keys %{ $r->{S} }) {
+       my $names;
        if ($pncn =~ m/_param_name$/) {
            my $name = $r->{S}{$pncn};
            die "$pncn ?" if ref $name;
@@ -492,7 +494,7 @@ sub _chain_params ($) {
        } else {
            next;
        }
-       foreach my $param (@$names) {
+       foreach my $name (@$names) {
            delete $p{$name};
        }
     }
@@ -500,17 +502,18 @@ sub _chain_params ($) {
 }
 
 sub _db_lookup ($$) {
+    my ($r,$v) = @_;
     # returns ($t,$username)
     # where $t is one of "t" "y" "n", or "" (for -)
-    my ($r,$v) = @_;
 
     my $dbh = $r->{Dbh};
 
-    my ($nusername, $nlast) =
-       $dbh->selectrow_array("SELECT username, last".
+    my $row = $dbh->selectrow_arrayref("SELECT username, last".
                              " FROM $r->{S}{assocdb_table}".
-                             " WHERE associd = ?", {}, $nassoc);
-    return ('') unless defined $nusername;
+                             " WHERE associd = ?", {}, $v);
+    return ('') unless defined $row;
+
+    my ($nusername, $nlast) = @$row;
 
     my $timeout = $r->{S}{login_timeout};
     return ('n') unless !defined $timeout || time <= $nlast + $timeout;
@@ -534,6 +537,7 @@ sub _db_revoke ($$) {
 sub _db_record_login_ok ($$$) {
     my ($r,$v,$user) = @_;
     $r->_db_revoke($v);
+    my $dbh = $r->{Dbh};
     $dbh->do("INSERT INTO $r->{S}{assocdb_table}".
             " (associd, username, last) VALUES (?,?,?)", {},
             $v, $user, time);
@@ -545,6 +549,7 @@ sub check_divert ($) {
     if (exists $r->{Divert}) {
         return $r->{Divert};
     }
+    my $dbh = $r->{Dbh};
     $dbh->do("BEGIN");
     if (!eval {
         $divert = $r->_check_divert_core();
@@ -594,11 +599,11 @@ sub check_ok ($) {
     if ($kind =~ m/^REDIRECT-/) {
        # for redirects, we honour stored NextParams and SetCookie,
        # as we would for non-divert
-       if ($divert_kind eq 'REDIRECT-LOGGEDOUT') {
-           $params{$r->{S}{loggedout_param_names}[0]} = 1;
-       } elsif ($divert_kind eq 'REDIRECT-LOGOUT') {
-           $params{$r->{S}{logout_param_names}[0]} = 1;
-       } elsif ($divert_kind eq 'REDIRECT-LOGGEDIN') {
+       if ($kind eq 'REDIRECT-LOGGEDOUT') {
+           $params->{$r->{S}{loggedout_param_names}[0]} = 1;
+       } elsif ($kind eq 'REDIRECT-LOGOUT') {
+           $params->{$r->{S}{logout_param_names}[0]} = 1;
+       } elsif ($kind eq 'REDIRECT-LOGGEDIN') {
        } else {
            die;
        }
@@ -630,10 +635,10 @@ sub check_ok ($) {
 sub _random ($$) {
     my ($r, $bytes) = @_;
     my $v = $r->{V};
-    if (!$v->{RandomHandle}) {
-       my $rsp = $r->{S}{random_source};
-       my $rsf = new IO::File $rsp, '<' or die "$rsp $!";
-       $v->{RandomHandle} = $rsf;
+    my $rsf = $v->{RandomHandle};
+    my $rsp = $r->{S}{random_source};
+    if (!$rsf) {
+       $v->{RandomHandle} = $rsf = new IO::File $rsp, '<' or die "$rsp $!";
     }
     my $bin;
     $!=0;

diff --git a/test.cgi b/test.cgi
index edf0ff02af1fadfdd96c13b0041cae65b6aa7682..b9295513ee876396d2253d0f10141bf1592d4eaf 100755 (executable)
--- a/test.cgi
+++ b/test.cgi
@@ -3,10 +3,11 @@
 use strict;
 use warnings;
 use CGI;
+use CGI::Auth::Hybrid;
 
-my $dump = "/u/iwj/work/Ssh-gateway/cgi-auth-hybrid.git/dump";
+my $dump = "$ENV{'CAHTEST_HOME'}/dump";
 
-require 'cgi-auth-hybrid.pm';
+#require 'cgi-auth-hybrid.pm';
 
 my $verifier = CGI::Auth::Hybrid->new_verifier(
    assocdb_path => "$dump/assoc.db",