Apache-AuthTicket
1 match

 view release on metacpan or  search on metacpan

lib/Apache/AuthTicket/Base.pm  view on Meta::CPAN 

        $reason = $r->prev->subprocess_env("AuthTicketReason");
        $r->log_error("AUTHTICKET REASON: $reason");
    }

    $r->content_type('text/html');

    $r->send_http_header if ModPerl::VersionUtil->is_mp1;

    $r->print(
        q{<!DOCTYPE HTML PUBLIC  "-//W3C//DTD HTML 3.2//EN">},
        q{<HTML>},
        q{<HEAD>},
        q{<TITLE>Log in</TITLE>},
        q{</HEAD>},
        q{<BODY bgcolor="#ffffff">},
        q{<H1>Please Log In</H1>}
    );

    $r->print(
        qq{<form method="post" action="$action">},
        qq{<input type="hidden" name="destination" value="$destination">},
        q{<table>},
        q{<tr>},
        q{<td>Name</td>},
        q{<td><input type="text" name="credential_0"></td>},
        q{</tr>},
        q{<tr>},
        q{<td>Password</td>},
        q{<td><input type="password" name="credential_1"></td>},
        q{</tr>},
        q{</table>},
        q{<input type="submit" value="Log In">},
        q{<p>},
        q{</form>},
        q{<EM>Note: </EM>},
        q{Set your browser to accept cookies in order for login to succeed.},
        q{You will be asked to log in again after some period of time.},
        q{</body></html>}
    );

    return $self->apache_const('OK');
}

sub logout ($$) {
    my ($class, $r) = @_;

    my $self = $class->new($r);

    $self->delete_ticket($r);
    $self->next::method($r); # AuthCookie logout

    $r->headers_out->add(Location => $self->get_config('TicketLogoutURI'));

    return $class->apache_const('REDIRECT');
}

##################### END STATIC METHODS ###########################3
sub new {
    my ($class, $r) = @_;

    return $class->SUPER::new({request => $r});
}

sub dbh {
    my $self = shift;

    unless (defined $self->_dbh) {
        $self->_dbh($self->dbi_connect);
    }

    $self->_dbh;
}

sub dbi_connect {
    my $self = shift;

    my $r         = $self->request;
    my $auth_name = $r->auth_name;

    my ($db, $user, $pass) = map {
        $self->get_config($_)
    } qw/TicketDB TicketDBUser TicketDBPassword/;

    my $dbh = DBI->connect_cached($db, $user, $pass)
        or die "DBI Connect failure: ", DBI->errstr, "\n";

    return $dbh;
}

sub check_credentials {
    my ($self, $user, $password) = @_;

    my ($table, $user_field, $pass_field) = $self->user_table;

    my ($stmt, @bind) =
        $self->sql->select($table, $pass_field, {$user_field => $user});

    my ($db_pass) = eval {
        $self->dbh->selectrow_array($stmt, undef, @bind);
    };
    if ($@) {
        $self->dbh->rollback;
        return 0;
    }

    unless (defined $db_pass) {
        # user not in database
        return 0;
    }

    my $style = $self->get_config('TicketPasswordStyle');

    if ($self->compare_password($style, $password, $db_pass)) {
        return 1;
    }
    else {
        return 0;
    }
}

sub fetch_secret {



( run in 0.490 second using v1.01-cache-2.11-cpan-0bb4e1dffa6 )