Cook results from the CPAN

Cook
Apache-AuthTicket
view release on metacpan or search on metacpan
lib/Apache/AuthTicket/Base.pm view on Meta::CPAN
    my $newhash = $self->hash_for(@fields);

    if ($newhash eq $hash) {
        return 1;
    }
    else {
        return 0;
    }
}

sub sql {
    my $self = shift;

    unless (defined $self->_sql) {
        $self->_sql( SQL::Abstract->new );
    }

    $self->_sql;
}

sub get_config {
    my ($self, $name) = @_;

    unless (defined $self->{config}{$name}) {
        my $r = $self->request;
        my $auth_name = $r->auth_name;

        $self->{config}{$name} =
            $self->str_config_value(
                $r->dir_config("${auth_name}$name"),
                $CONFIG{$auth_name}{$name},
                $DEFAULTS{$name});
    }

    return $self->{config}{$name}
}

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

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

    my $action = $self->get_config('TicketLoginHandler');

    my $destination = $r->prev->uri;
    my $args = $r->prev->args;
    if ($args) {
        $destination .= "?$args";
    }

    $class->make_login_screen($r, $action, $destination);

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

sub make_login_screen {
    my ($self, $r, $action, $destination) = @_;

    if (DEBUGGING) {
        # log what we think is wrong.
        my $reason = $r->prev->subprocess_env("AuthCookieReason");
        $r->log_error("REASON FOR AUTH NEEDED: $reason");
        $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;
    }
( run in 0.418 second using v1.01-cache-2.11-cpan-39bf76dae61 )