view release on metacpan or  search on metacpan

lib/Apache/AuthCookie.pm  view on Meta::CPAN

package Apache::AuthCookie;
$Apache::AuthCookie::VERSION = '3.31';
# ABSTRACT: Perl Authentication and Authorization via cookies

use strict;

use Carp;
use mod_perl qw(1.07 StackedHandlers MethodHandlers Authen Authz);
use Apache::Constants qw(:common M_GET FORBIDDEN OK REDIRECT);
use Apache::AuthCookie::Params;
use Apache::AuthCookie::Util qw(is_blank is_local_destination);
use Apache::Util qw(escape_uri);
use Apache::URI;
use Encode ();


sub recognize_user ($$) {
    my ($self, $r) = @_;

    # only check if user is not already set
    return DECLINED unless is_blank($r->connection->user);

    my $debug = $r->dir_config("AuthCookieDebug") || 0;
    my ($auth_type, $auth_name) = ($r->auth_type, $r->auth_name);

    return DECLINED if is_blank($auth_type) or is_blank($auth_name);

    return DECLINED if is_blank($r->header_in('Cookie'));

    my $cookie_name = $self->cookie_name($r);

    my ($cookie) = $r->header_in('Cookie') =~ /$cookie_name=([^;]+)/;
    $r->log_error("cookie $cookie_name is $cookie") if $debug >= 2;
    return DECLINED unless $cookie;

    my ($user, @args) = $auth_type->authen_ses_key($r, $cookie);
    if (!is_blank($user) and scalar @args == 0) {
        $r->log_error("user is $user") if $debug >= 2;

        # if SessionTimeout is on, send new cookie with new Expires.
        if (my $expires = $r->dir_config("${auth_name}SessionTimeout")) {
            $self->send_cookie($cookie, { expires => $expires });
        }

        $r->connection->user( $self->_encode($r, $user) );
    }
    elsif (scalar @args > 0 and $auth_type->can('custom_errors')) {
        return $auth_type->custom_errors($r, $user, @args);
    }

    return is_blank($user) ? DECLINED : OK;
}

sub cookie_name {
    my ($self, $r) = @_;

    my $auth_type = $r->auth_type;
    my $auth_name = $r->auth_name;

    my $cookie_name = $r->dir_config("${auth_name}CookieName")
        || "${auth_type}_${auth_name}";

    return $cookie_name;
}


sub encoding {
    my ($self, $r) = @_;

    my $auth_name = $r->auth_name;

    return $r->dir_config("${auth_name}Encoding");
}


sub requires_encoding {
    my ($self, $r) = @_;

    my $auth_name = $r->auth_name;

    return $r->dir_config("${auth_name}RequiresEncoding");
}


sub decoded_user {
    my ($self, $r) = @_;

    my $user = $r->connection->user;

    if (is_blank($user)) {
        return $user;
    }

    my $encoding = $self->encoding($r);

    if (!is_blank($encoding)) {
        $user = Encode::decode($encoding, $user);
    }

    return $user;
}