Apache2::AuthCookieDBI - An AuthCookie module backed by a DBI database.

    This is version 2.14

    # In httpd.conf or .htaccess

    # Optional: Initiate a persistent database connection using Apache::DBI.
    # See: http://search.cpan.org/dist/Apache-DBI/
    # If you choose to use Apache::DBI then the following directive must come
    # before all other modules using DBI - just uncomment the next line:
    #PerlModule Apache::DBI  

     


    PerlModule Apache2::AuthCookieDBI
    PerlSetVar WhatEverPath /
    PerlSetVar WhatEverLoginScript /login.pl

    # Optional, to share tickets between servers.
    PerlSetVar WhatEverDomain .domain.com

    # These must be set
    PerlSetVar WhatEverDBI_DSN "DBI:mysql:database=test"
    PerlSetVar WhatEverDBI_SecretKey "489e5eaad8b3208f9ad8792ef4afca73598ae666b0206a9c92ac877e73ce835c"

    # These are optional, the module sets sensible defaults.
    PerlSetVar WhatEverDBI_User "nobody"
    PerlSetVar WhatEverDBI_Password "password"
    PerlSetVar WhatEverDBI_UsersTable "users"
    PerlSetVar WhatEverDBI_UserField "user"
    PerlSetVar WhatEverDBI_PasswordField "password"
    PerlSetVar WhatEverDBI_UserActiveField "" # Default is skip this feature
    PerlSetVar WhatEverDBI_CryptType "none"
    PerlSetVar WhatEverDBI_GroupsTable "groups"
    PerlSetVar WhatEverDBI_GroupField "grp"
    PerlSetVar WhatEverDBI_GroupUserField "user"
    PerlSetVar WhatEverDBI_EncryptionType "none"
    PerlSetVar WhatEverDBI_SessionLifetime 00-24-00-00

    # Protected by AuthCookieDBI.
    <Directory /www/domain.com/authcookiedbi>
        AuthType Apache2::AuthCookieDBI
        AuthName WhatEver
        PerlAuthenHandler Apache2::AuthCookieDBI->authenticate
        PerlAuthzHandler Apache2::AuthCookieDBI->authorize
        require valid-user
        # or you can require users:
        require user jacob
        # You can optionally require groups.
        require group system
    </Directory>

    # Login location.
    <Files LOGIN>
        AuthType Apache2::AuthCookieDBI
        AuthName WhatEver
        SetHandler perl-script
        PerlHandler Apache2::AuthCookieDBI->login

        # If the directopry you are protecting is the DocumentRoot directory
        # then uncomment the following directive:
        #Satisfy any
    </Files>

    PerlSetVar PrivateBankingSystemDBI_DSN "DBI:mysql:database=banking"

    CREATE TABLE users (
        user VARCHAR(16) PRIMARY KEY,
        password VARCHAR(32) NOT NULL
    )

    CREATE TABLE groups (
        grp VARCHAR(16) NOT NULL,
        user VARCHAR(16) NOT NULL
    )

 Copyright (C) 2002 SF Interactive.
 Copyright (C) 2003-2004 Jacob Davies
 Copyright (C) 2004-2010 Matisse Enzer

  Original Author: Jacob Davies
  Incomplete list of additional contributors (alphabetical by first name):
    Carl Gustafsson
    Chad Columbus
    Jay Strauss
    Joe Ingersoll
    Keith Lawson
    Lance P Cleveland
    Matisse Enzer
    Nick Phillips
    William McKee

        <matisse@cpan.org>

 Apache2::AuthCookie - http://search.cpan.org/dist/Apache2-AuthCookie
 Apache2::Session    - http://search.cpan.org/dist/Apache2-Session
 Apache::AuthDBI     - http://search.cpan.org/dist/Apache-DBI

#===============================================================================
#
# $Id: AuthCookieDBI.pm,v 1.60 2011/03/12 20:14:41 matisse Exp $
#
# Apache2::AuthCookieDBI
#
# An AuthCookie module backed by a DBI database.
#
# See end of this file for Copyright notices.
#
# Author:  Jacob Davies <jacob@well.com>
# Maintainer: Matisse Enzer <matisse@cpan.org> (as of version 2.0)
#
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public
# License as published by the Free Software Foundation; either
# version 2.1 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public
# License along with this library; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
#===============================================================================

package Apache2::AuthCookieDBI;

use strict;
use warnings;
use 5.004;
our $VERSION = 2.14;

use Apache2::AuthCookie;
use base qw( Apache2::AuthCookie );

use Apache2::RequestRec;
use DBI;
use Apache2::Const -compile => qw( OK HTTP_FORBIDDEN SERVER_ERROR );
use Apache2::ServerUtil;
use Carp qw();
use Digest::MD5 qw( md5_hex );
use Date::Calc qw( Today_and_Now Add_Delta_DHMS );

# Also uses Crypt::CBC if you're using encrypted cookies.
# Also uses Apache2::Session if you're using sessions.
use English qw(-no_match_vars);

#===============================================================================
# FILE (LEXICAL)  G L O B A L S
#===============================================================================

my %CIPHERS = ();

# Stores Cipher::CBC objects in $CIPHERS{ idea:AuthName },
# $CIPHERS{ des:AuthName } etc.

use constant COLON_REGEX => qr/ : /mx;
use constant DATE_TIME_STRING_REGEX =>
    qr/ \A \d{4}-\d{2}-\d{2}-\d{2}-\d{2}-\d{2} \z /mx;
use constant EMPTY_STRING                 => q{};
use constant HEX_STRING_REGEX             => qr/ \A [0-9a-fA-F]+ \z /mx;
use constant HYPHEN_REGEX                 => qr/ - /mx;
use constant PERCENT_ENCODED_STRING_REGEX => qr/ \A [a-zA-Z0-9_\%]+ \z /mx;
use constant THIRTY_TWO_CHARACTER_HEX_STRING_REGEX =>
    qr/  \A [0-9a-fA-F]{32} \z /mx;
use constant TRUE             => 1;
use constant WHITESPACE_REGEX => qr/ \s+ /mx;

#===============================================================================
# P E R L D O C
#===============================================================================

#===============================================================================
# P R I V A T E   F U N C T I O N S
#===============================================================================

# Get the cipher from the cache, or create a new one if the
# cached cipher hasn't been created.
sub _get_cipher_for_type {
    my ( $class, $dbi_encryption_type, $auth_name, $secret_key ) = @_;
    my $lc_encryption_type = lc $dbi_encryption_type;

    if ( exists $CIPHERS{"$lc_encryption_type:$auth_name"} ) {
        return $CIPHERS{"$lc_encryption_type:$auth_name"};
    }

    my %cipher_for_type = (
        des => sub {
            return $CIPHERS{"des:$auth_name"}
                || Crypt::CBC->new( -key => $secret_key, -cipher => 'DES' );
        },
        idea => sub {
            return $CIPHERS{"idea:$auth_name"}
                || Crypt::CBC->new( -key => $secret_key, -cipher => 'IDEA' );
        },
        blowfish => sub {
            return $CIPHERS{"blowfish:$auth_name"}
                || Crypt::CBC->new(
                -key    => $secret_key,
                -cipher => 'Blowfish'
                );
        },
        blowfish_pp => sub {
            return $CIPHERS{"blowfish_pp:$auth_name"}
                || Crypt::CBC->new(
                -key    => $secret_key,
                -cipher => 'Blowfish_PP'
                );
        },
    );
    my $code_ref = $cipher_for_type{$lc_encryption_type}
        || Carp::confess("Unsupported encryption type: '$dbi_encryption_type'");
    my $cbc_object = $code_ref->();

    # Cache the object. Caught bug where we were not, thanks to unit tests.
    $CIPHERS{"$lc_encryption_type:$auth_name"} = $cbc_object;

    return $cbc_object;
}

sub _encrypt_session_key {
    my $class               = shift;
    my $session_key         = shift;
    my $secret_key          = shift;
    my $auth_name           = shift;
    my $dbi_encryption_type = lc shift;

    if ( !defined $dbi_encryption_type ) {
        Carp::confess('$dbi_encryption_type must be defined.');
    }

    if ( $dbi_encryption_type eq 'none' ) {
        return $session_key;
    }

    my $cipher = $class->_get_cipher_for_type( $dbi_encryption_type, $auth_name,
        $secret_key );
    my $encrypted_key = $cipher->encrypt_hex($session_key);
    return $encrypted_key;
}

#-------------------------------------------------------------------------------
# _log_not_set -- Log that a particular authentication variable was not set.

sub _log_not_set {
    my ( $r, $variable ) = @_;
    my $auth_name = $r->auth_name;
    return $r->log_error(
        "Apache2::AuthCookieDBI: $variable not set for auth realm $auth_name",
        $r->uri );
}

#-------------------------------------------------------------------------------
# _dir_config_var -- Get a particular authentication variable.

sub _dir_config_var {
    my ( $class, $r, $variable ) = @_;
    my $auth_name = $r->auth_name;
    return $r->dir_config("$auth_name$variable");
}

#-------------------------------------------------------------------------------
# _dbi_config_vars -- Gets the config variables from the dir_config and logs
# errors if required fields were not set, returns undef if any of the fields
# had errors or a hash of the values if they were all OK.  Takes a request
# object.

my %CONFIG_DEFAULT = (
    DBI_DSN             => undef,
    DBI_SecretKey       => undef,
    DBI_User            => undef,
    DBI_Password        => undef,
    DBI_UsersTable      => 'users',
    DBI_UserField       => 'user',
    DBI_PasswordField   => 'password',
    DBI_UserActiveField => EMPTY_STRING,    # Default is don't use this feature
    DBI_CryptType       => 'none',
    DBI_GroupsTable     => 'groups',
    DBI_GroupField      => 'grp',
    DBI_GroupUserField  => 'user',
    DBI_EncryptionType  => 'none',
    DBI_SessionLifetime => '00-24-00-00',
    DBI_sessionmodule   => 'none',
);

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

    my %c;    # config variables hash
    foreach my $variable ( keys %CONFIG_DEFAULT ) {
        my $value_from_config = $class->_dir_config_var( $r, $variable );
        $c{$variable}
            = defined $value_from_config
            ? $value_from_config
            : $CONFIG_DEFAULT{$variable};
        if ( !defined $c{$variable} ) {
            _log_not_set( $r, $variable );
        }
    }

    # If we used encryption we need to pull in Crypt::CBC.
    if ( $c{'DBI_EncryptionType'} ne 'none' ) {
        require Crypt::CBC;
    }

    return %c;
}

#-------------------------------------------------------------------------------
# _now_year_month_day_hour_minute_second -- Return a string with the time in
# this order separated by dashes.

sub _now_year_month_day_hour_minute_second {
    return sprintf '%04d-%02d-%02d-%02d-%02d-%02d', Today_and_Now;
}

sub _check_password {
    my ( $class, $password, $crypted_password, $crypt_type ) = @_;

    return
        if not $crypted_password
    ;    # https://rt.cpan.org/Public/Bug/Display.html?id=62470

    my %password_checker = (
        none => sub { return $password eq $crypted_password; },
        'crypt' => sub {
            my $salt = substr $crypted_password, 0, 2;
            return crypt( $password, $salt ) eq $crypted_password;
        },
        md5 => sub { return md5_hex($password) eq $crypted_password; },
    );
    return $password_checker{$crypt_type}->();
}

#-------------------------------------------------------------------------------
# _percent_encode -- Percent-encode (like URI encoding) any non-alphanumberics
# in the supplied string.

sub _percent_encode {
    my ($str) = @_;
    my $not_a_word = qr/ ( \W ) /x;
    $str =~ s/$not_a_word/ uc sprintf '%%%02x', ord $1 /xmeg;
    return $str;
}

#-------------------------------------------------------------------------------
# _percent_decode -- Percent-decode (like URI decoding) any %XX sequences in
# the supplied string.

sub _percent_decode {
    my ($str) = @_;
    my $percent_hex_string_regex = qr/ %([0-9a-fA-F]{2}) /x;
    $str =~ s/$percent_hex_string_regex/ pack( "c",hex( $1 ) ) /xmge;
    return $str;
}

#-------------------------------------------------------------------------------
# _dbi_connect -- Get a database handle.

sub _dbi_connect {
    my ( $class, $r ) = @_;
    Carp::confess('Failed to pass Apache request object') if not $r;

    my %c = $class->_dbi_config_vars($r);

    # get the crypted password from the users database for this user.
    my $dbh = DBI->connect_cached( $c{'DBI_DSN'}, $c{'DBI_User'},
        $c{'DBI_Password'} );
    if ( defined $dbh ) {
        return $dbh;
    }
    else {
        my $auth_name = $r->auth_name;
        $r->log_error(
            "$class: couldn't connect to $c{'DBI_DSN'} for auth realm $auth_name",
            $r->uri
        );
        my ( $pkg, $file, $line, $sub ) = caller(1);
        $r->log_error("${class}->_dbi_connect called in $sub at line $line");
        return;
    }
}

#-------------------------------------------------------------------------------
# _get_crypted_password -- Get the users' password from the database
sub _get_crypted_password {
    my ( $class, $r, $user ) = @_;
    my $dbh = $class->_dbi_connect($r) || return;
    my %c = $class->_dbi_config_vars($r);

    if ( !$class->user_is_active( $r, $user ) ) {
        my $message = "User '$user' is not active.";
        $r->log_error( $message, $r->uri() );
        return;
    }

    my $crypted_password = EMPTY_STRING;

    my $sql_query = <<"SQL";
      SELECT $c{'DBI_PasswordField'}
      FROM $c{'DBI_UsersTable'}
      WHERE $c{'DBI_UserField'} = ?
      AND ($c{'DBI_PasswordField'} != ''
      AND $c{'DBI_PasswordField'} IS NOT NULL)
SQL
    my $sth = $dbh->prepare_cached($sql_query);
    $sth->execute($user);
    ($crypted_password) = $sth->fetchrow_array();
    $sth->finish();

    if ( _is_empty($crypted_password) ) {
        my $message = "Could not select password using SQL query '$sql_query'";
        $r->log_error( $message, $r->uri() );
        return;
    }
    return $crypted_password;
}

sub _get_new_session {
    my $class          = shift;
    my $r              = shift;
    my $user           = shift;
    my $auth_name      = shift;
    my $session_module = shift;
    my $extra_data     = shift;

    my $dbh = $class->_dbi_connect($r);
    my %session;
    tie %session, $session_module, undef,
        +{
        Handle     => $dbh,
        LockHandle => $dbh,
        };

    $session{'user'}       = $user;
    $session{'extra_data'} = $extra_data;
    return \%session;
}

# Takes a list and returns a list of the same size.
# Any element in the inputs that is defined is returned unchanged. Elements that
# were undef are returned as empty strings.
sub _defined_or_empty {
    my @args        = @_;
    my @all_defined = ();
    foreach my $arg (@args) {
        if ( defined $arg ) {
            push @all_defined, $arg;
        }
        else {
            push @all_defined, EMPTY_STRING;
        }
    }
    return @all_defined;
}

sub _is_empty {
    my $string = shift;
    return TRUE if not defined $string;
    return TRUE if $string eq EMPTY_STRING;
    return;
}

#===============================================================================
# P U B L I C   F U N C T I O N S
#===============================================================================

sub extra_session_info {
    my ( $class, $r, $user, $password, @extra_data ) = @_;

    return EMPTY_STRING;
}

sub authen_cred {
    my ( $class, $r, $user, $password, @extra_data ) = @_;
    my $auth_name = $r->auth_name;
    ( $user, $password ) = _defined_or_empty( $user, $password );

    if ( !length $user ) {
        $r->log_error(
            "Apache2::AuthCookieDBI: no username supplied for auth realm $auth_name",
            $r->uri
        );
        return;
    }

    if ( !length $password ) {
        $r->log_error(
            "Apache2::AuthCookieDBI: no password supplied for auth realm $auth_name",
            $r->uri
        );
        return;
    }

    # get the configuration information.
    my %c = $class->_dbi_config_vars($r);

    # get the crypted password from the users database for this user.
    my $crypted_password = $class->_get_crypted_password( $r, $user, \%c );

    # now return unless the passwords match.
    my $crypt_type = lc $c{'DBI_CryptType'};
    if ( !$class->_check_password( $password, $crypted_password, $crypt_type ) )
    {
        $r->log_error(
            "Apache2::AuthCookieDBI: $crypt_type passwords didn't match for user $user for auth realm $auth_name",
            $r->uri
        );
        return;
    }

    # Create the expire time for the ticket.
    my $expire_time = _get_expire_time( $c{'DBI_SessionLifetime'} );

    # Now we need to %-encode non-alphanumberics in the username so we
    # can stick it in the cookie safely.
    my $enc_user = _percent_encode($user);

    # If we are using sessions, we create a new session for this login.
    my $session_id = EMPTY_STRING;
    if ( $c{'DBI_sessionmodule'} ne 'none' ) {
        my $session = $class->_get_new_session(
            $r, $user, $auth_name, $c{'DBI_sessionmodule'},
            \@extra_data
        );
        $r->pnotes( $auth_name, $session );
        $session_id = $session->{_session_id};
    }

    # OK, now we stick the username and the current time and the expire
    # time and the session id (if any) together to make the public part
    # of the session key:
    my $current_time = _now_year_month_day_hour_minute_second;
    my $public_part  = "$enc_user:$current_time:$expire_time:$session_id";
    $public_part
        .= $class->extra_session_info( $r, $user, $password, @extra_data );

    # Now we calculate the hash of this and the secret key and then
    # calculate the hash of *that* and the secret key again.
    my $secretkey = $c{'DBI_SecretKey'};
    if ( !defined $secretkey ) {
        $r->log_error(
            "Apache2::AuthCookieDBI: didn't have the secret key for auth realm $auth_name",
            $r->uri
        );
        return;
    }
    my $hash = md5_hex( join q{:}, $secretkey,
        md5_hex( join q{:}, $public_part, $secretkey ) );

    # Now we add this hash to the end of the public part.
    my $session_key = "$public_part:$hash";

    # Now we encrypt this and return it.
    my $encrypted_session_key
        = $class->_encrypt_session_key( $session_key, $secretkey, $auth_name,
        $c{'DBI_EncryptionType'} );
    return $encrypted_session_key;
}

#-------------------------------------------------------------------------------
# Take a session key and check that it is still valid; if so, return the user.

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

    my $auth_name = $r->auth_name;

    # Get the configuration information.
    my %c = $class->_dbi_config_vars($r);

    # Get the secret key.
    my $secret_key = $c{'DBI_SecretKey'};
    if ( !defined $secret_key ) {
        $r->log_error(
            "$class: didn't have the secret key from for auth realm $auth_name",
            $r->uri
        );
        return;
    }

    my $session_key = $class->decrypt_session_key( $r, $c{'DBI_EncryptionType'},
        $encrypted_session_key, $secret_key )
        || return;

    # Break up the session key.
    my ( $enc_user, $issue_time, $expire_time, $session_id, @rest )
        = split COLON_REGEX, $session_key;
    my $hashed_string = pop @rest;

    # Let's check that we got passed sensible values in the cookie.
    ($enc_user) = _defined_or_empty($enc_user);
    if ( $enc_user !~ PERCENT_ENCODED_STRING_REGEX ) {
        $r->log_error(
            "$class: bad percent-encoded user '$enc_user' recovered from session ticket for auth_realm '$auth_name'",
            $r->uri
        );
        return;
    }

    # decode the user
    my $user = _percent_decode($enc_user);

    ($issue_time) = _defined_or_empty($issue_time);
    if ( $issue_time !~ DATE_TIME_STRING_REGEX ) {
        $r->log_error(
            "$class: bad issue time '$issue_time' recovered from ticket for user $user for auth_realm $auth_name",
            $r->uri
        );
        return;
    }

    ($expire_time) = _defined_or_empty($expire_time);
    if ( $expire_time !~ DATE_TIME_STRING_REGEX ) {
        $r->log_error(
            "$class: bad expire time $expire_time recovered from ticket for user $user for auth_realm $auth_name",
            $r->uri
        );
        return;
    }
    if ( $hashed_string !~ THIRTY_TWO_CHARACTER_HEX_STRING_REGEX ) {
        $r->log_error(
            "$class: bad encrypted session_key $hashed_string recovered from ticket for user $user for auth_realm $auth_name",
            $r->uri
        );
        return;
    }

    # If we're using a session module, check that their session exist.
    if ( $c{'DBI_sessionmodule'} ne 'none' ) {
        my %session;
        my $dbh = $class->_dbi_connect($r) || return;

        my $tie_result = eval {
            tie %session, $c{'DBI_sessionmodule'}, $session_id,
                +{
                Handle     => $dbh,
                LockHandle => $dbh,
                };
        };
        if ( ( !$tie_result ) || $EVAL_ERROR ) {
            $r->log_error(
                "$class: failed to tie session hash to '$c{'DBI_sessionmodule'}' using session id $session_id for user $user for auth_realm $auth_name, error was '$EVAL_ERROR'",
                $r->uri
            );
            return;
        }

        # Update a timestamp at the top level to make sure we sync.
        $session{timestamp} = _now_year_month_day_hour_minute_second;
        $r->pnotes( $auth_name, \%session );
    }

    # Calculate the hash of the user, issue time, expire_time and
    # the secret key  and the session_id and then the hash of that
    # and the secret key again.
    my $new_hash = md5_hex(
        join q{:},
        $secret_key,
        md5_hex(
            join q{:},   $enc_user, $issue_time, $expire_time,
            $session_id, @rest,     $secret_key
        )
    );

    # Compare it to the hash they gave us.
    if ( $new_hash ne $hashed_string ) {
        $r->log_error(
            "$class: hash '$hashed_string' in cookie did not match calculated hash '$new_hash' of contents for user $user for auth realm $auth_name",
            $r->uri
        );
        return;
    }

    # Check that their session hasn't timed out.
    if ( _now_year_month_day_hour_minute_second gt $expire_time ) {
        $r->log_error(
            "$class: expire time $expire_time has passed for user $user for auth realm $auth_name",
            $r->uri
        );
        return;
    }

    # If we're being paranoid about timing-out long-lived sessions,
    # check that the issue time + the current (server-set) session lifetime
    # hasn't passed too (in case we issued long-lived session tickets
    # in the past that we want to get rid of). *** TODO ***
    # if ( lc $c{'DBI_AlwaysUseCurrentSessionLifetime'} eq 'on' ) {

    # They must be okay, so return the user.
    return $user;
}

sub decrypt_session_key {
    my ( $class, $r, $encryptiontype, $encrypted_session_key, $secret_key )
        = @_;

    if ( $encryptiontype eq 'none' ) {
        return $encrypted_session_key;
    }

    my $auth_name = $r->auth_name;

    my $session_key;

    # Check that this looks like an encrypted hex-encoded string.
    if ( $encrypted_session_key !~ HEX_STRING_REGEX ) {
        $r->log_error(
            "Apache2::AuthCookieDBI: encrypted session key '$encrypted_session_key' doesn't look like it's properly hex-encoded for auth realm $auth_name",
            $r->uri
        );
        return;
    }

    my $cipher = $class->_get_cipher_for_type( $encryptiontype, $auth_name,
        $secret_key );
    if ( !$cipher ) {
        $r->log_error(
            "Apache2::AuthCookieDBI: unknown encryption type '$encryptiontype' for auth realm $auth_name",
            $r->uri
        );
        return;
    }
    $session_key = $cipher->decrypt_hex($encrypted_session_key);
    return $session_key;
}

sub group {
    my ( $class, $r, $groups ) = @_;
    my @groups = split( WHITESPACE_REGEX, $groups );

    my $auth_name = $r->auth_name;

    # Get the configuration information.
    my %c = $class->_dbi_config_vars($r);

    my $user = $r->user;

    # See if we have a row in the groups table for this user/group.
    my $dbh = $class->_dbi_connect($r) || return Apache2::Const::SERVER_ERROR;

    # Now loop through all the groups to see if we're a member of any:
    my $sth = $dbh->prepare_cached( <<"EOS" );
SELECT $c{'DBI_GroupUserField'}
FROM $c{'DBI_GroupsTable'}
WHERE $c{'DBI_GroupField'} = ?
AND $c{'DBI_GroupUserField'} = ?
EOS
    foreach my $group (@groups) {
        $sth->execute( $group, $user );
        if ( $sth->fetchrow_array ) {
            $sth->finish();

            # add the group to an ENV var that CGI programs can access:
            $r->subprocess_env( 'AUTH_COOKIE_DBI_GROUP' => $group );
            return Apache2::Const::OK;
        }
    }
    $sth->finish();

    $r->log_error(
        "$class: user $user was not a member of any of the required groups @groups for auth realm $auth_name",
        $r->uri
    );
    return Apache2::Const::HTTP_FORBIDDEN;
}

sub user_is_active {
    my ( $class, $r, $user ) = @_;
    my %c                 = $class->_dbi_config_vars($r);
    my $active_field_name = $c{'DBI_UserActiveField'};

    if ( !$active_field_name ) {
        return TRUE;    # Default is that users are active
    }

    my $dbh = $class->_dbi_connect($r) || return;
    my $sql_query = <<"SQL";
      SELECT $active_field_name
      FROM $c{'DBI_UsersTable'}
      WHERE $c{'DBI_UserField'} = ?
SQL

    my $sth = $dbh->prepare_cached($sql_query);
    $sth->execute($user);
    my ($user_active_setting) = $sth->fetchrow_array;
    $sth->finish();

    return $user_active_setting;
}

#-------------------------------------------------------------------------------

sub _get_expire_time {
    my $session_lifetime = shift;
    $session_lifetime = lc $session_lifetime;

    my $expire_time = EMPTY_STRING;

    if ( $session_lifetime eq 'forever' ) {
        $expire_time = '9999-01-01-01-01-01';

        # expire time in a zillion years if it's forever.
        return $expire_time;
    }

    my ( $deltaday, $deltahour, $deltaminute, $deltasecond )
        = split HYPHEN_REGEX, $session_lifetime;

    # Figure out the expire time.
    $expire_time = sprintf(
        '%04d-%02d-%02d-%02d-%02d-%02d',
        Add_Delta_DHMS( Today_and_Now, $deltaday, $deltahour,
            $deltaminute, $deltasecond
        )
    );
    return $expire_time;
}

1;

__END__