wip fixes, debugging

[cgi-auth-flexible.git] / cgi-auth-hybrid.pm

diff --git a/cgi-auth-hybrid.pm b/cgi-auth-hybrid.pm
index 0617881eb1b81224a29301660c5ed3ba1fd24f46..d945faefa5cc44c388a430a76732dd9317c688c0 100644 (file)
--- a/cgi-auth-hybrid.pm
+++ b/cgi-auth-hybrid.pm
@@ -37,8 +37,10 @@ BEGIN {
 our @EXPORT_OK;
 
 use DBI;
-use CGI;
+use CGI qw/escapeHTML/;
 use Locale::gettext;
+use URI;
+use Data::Dumper;
 
 #---------- public utilities ----------
 
@@ -56,16 +58,17 @@ sub flatten_params ($) {
 #---------- default callbacks ----------
 
 sub has_a_param ($$) {
-    my ($c,$r,$cn) = @_;
+    my ($r,$cn) = @_;
     foreach my $pn (@{ $r->{S}{$cn} }) {
-       return 1 if $r->_cm('get_param',$pn);
+       return 1 if $r->_ch('get_param',$pn);
     }
     return 0;
 }
 
-sub get_params ($$) {
-    my ($c,$r) = @_;
+sub get_params ($) {
+    my ($r) = @_;
     my %p;
+    my $c = $r->{Cgi};
     foreach my $name ($c->param()) {
        $p{$name} = [ $c->param($name) ];
     }
@@ -204,15 +207,18 @@ sub _dbopen ($) {
     my $u = umask 077;
     $dbh = DBI->connect($dsn, $v->{S}{assocdb_user}, 
                         $v->{S}{assocdb_password}, { 
-                            AutoCommit => 0, RaiseError => 1,
+                            AutoCommit => 0,
+                            RaiseError => 1,
+                            ShowErrorStatement => 1,
                         });
     die "$dsn $! ?" unless $dbh;
     $v->{Dbh} = $dbh;
 
     eval {
-       $r->_db_transaction(sub {
+       $v->_db_transaction(sub {
+            local ($dbh->{PrintError}) = 0;
            $dbh->do("CREATE TABLE $v->{S}{assocdb_table} (".
-                    " associdh VARCHAR PRIMARY KEY,".
+                    " associd VARCHAR PRIMARY KEY,".
                     " username VARCHAR,".
                     " last INTEGER NOT NULL".
                     ")");
@@ -229,25 +235,35 @@ sub disconnect ($) {
 }
 
 sub _db_transaction ($$) {
-    my ($r, $fn) = @_;
+    my ($v, $fn) = @_;
     my $retries = 10;
     my $rv;
     my $dbh = $v->{Dbh};
+print STDERR "DT entry\n";
     for (;;) {
+print STDERR "DT loop\n";
        if (!eval {
            $rv = $fn->();
+print STDERR "DT fn ok\n";
            1;
        }) {
+print STDERR "DT fn error\n";
            { local ($@); $dbh->rollback(); }
+print STDERR "DT fn throwing\n";
            die $@;
        }
+print STDERR "DT fn eval ok\n";
        if (eval {
            $dbh->commit();
+print STDERR "DT commit ok\n";
            1;
        }) {
+print STDERR "DT commit eval ok $rv\n";
            return $rv;
        }
+print STDERR "DT commit throw?\n";
        die $@ if !--$retries;
+print STDERR "DT loop again\n";
     }
 }
 
@@ -272,6 +288,7 @@ sub new_request {
 sub _ch ($$@) { # calls an application hook
     my ($r,$methname, @args) = @_;
     my $methfunc = $r->{S}{$methname};
+    die "$methname ?" unless $methfunc;
     return $methfunc->($r->{Cgi}, $r, @args);
 }
 
@@ -286,12 +303,16 @@ 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},
+    return undef unless $cookv;
+    my $c = $r->{Cgi};
+    my $cookt = $c->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});
+print STDERR "CC $r $c $cookv $cookt\n";
+    return $cookt;
 }
 
 # pages/param-sets are
@@ -500,6 +521,7 @@ sub _check_divert_core ($) {
     die unless $cookv eq $parmv;
     $r->{Assoc} = $cookv;
     $r->{UserOK} = $cooku;
+    print STDERR "C-D-C OK\n";
     return undef;
 }
 
@@ -568,14 +590,14 @@ sub _db_record_login_ok ($$$) {
 
 sub check_divert ($) {
     my ($r) = @_;
-    my $divert;
     if (exists $r->{Divert}) {
         return $r->{Divert};
     }
     my $dbh = $r->{Dbh};
     $r->{Divert} = $r->_db_transaction(sub { $r->_check_divert_core(); });
     $dbh->commit();
-    return $divert;
+    print STDERR Dumper($r->{Divert});
+    return $r->{Divert};
 }
 
 sub get_divert ($) {
@@ -602,7 +624,7 @@ sub check_ok ($) {
     my ($r) = @_;
 
     my ($divert) = $r->check_divert();
-    return 1 if $divert;
+    return 1 if !$divert;
 
     my $handled = $r->_ch('handle_divert',$divert);
     return 0 if $handled;
@@ -641,9 +663,9 @@ sub check_ok ($) {
        die $kind;
     }
 
-    $r->_print($r->_ch('start_html',$title),
+    $r->_print($r->_ch('gen_start_html',$title),
               @body,
-              $r->_ch('end_html'));
+              $r->_ch('gen_end_html'));
     return 0;
 }
 
@@ -668,9 +690,14 @@ sub _fresh_cookie ($) {
     return $r->_random($bytes);
 }
 
-sub check_mutate ($) {
+sub _assert_checked ($) {
     my ($r) = @_;
     die "unchecked" unless exists $r->{Divert};
+}
+
+sub check_mutate ($) {
+    my ($r) = @_;
+    $r->_assert_checked();
     die if $r->{Divert};
     my $meth = $r->_ch('get_method');
     die "mutating non-POST" if $meth ne 'POST';
@@ -680,7 +707,7 @@ sub check_mutate ($) {
 
 sub secret_val ($) {
     my ($r) = @_;
-    $r->check();
+    $r->_assert_checked();
     return defined $r->{Assoc} ? $r->{Assoc} : '';
 }
 
@@ -692,7 +719,10 @@ sub secret_hidden_html ($) {
 
 sub secret_cookie ($) {
     my ($r) = @_;
-    return $r->construct_cookie($r->secret_val());
+#print STDERR "SC\n";
+    my $cookv = $r->construct_cookie($r->secret_val()); 
+#print STDERR "SC=$cookv\n";
+    return $cookv;
 }
 
 __END__