Apache::AuthDigestDBI - Authentication and Authorization via Perl's DBI,

 # Configuration in httpd.conf or startup.pl:

 PerlModule Apache::AuthDigestDBI

 # Authentication and Authorization in .htaccess:

 AuthName DBI
 AuthType Digest

 PerlAuthenHandler Apache::AuthDigestDBI::authen
 PerlAuthzHandler  Apache::AuthDigestDBI::authz

 PerlSetVar Auth_DBI_data_source   dbi:driver:dsn
 PerlSetVar Auth_DBI_username      db_username
 PerlSetVar Auth_DBI_password      db_password
 #DBI->connect($data_source, $username, $password)

 PerlSetVar Auth_DBI_pwd_table     users
 PerlSetVar Auth_DBI_uid_field     username
 PerlSetVar Auth_DBI_pwd_field     password
 # authentication: SELECT pwd_field FROM pwd_table WHERE uid_field=$user
 PerlSetVar Auth_DBI_grp_field     groupname
 # authorization: SELECT grp_field FROM pwd_table WHERE uid_field=$user

 require valid-user
 require user   user_1  user_2 ...
 require group group_1 group_2 ...

package Apache::AuthDigestDBI;

use Apache ();
use Apache::Constants qw( OK AUTH_REQUIRED FORBIDDEN DECLINED SERVER_ERROR );
use DBI ();
use IPC::SysV qw( IPC_CREAT IPC_RMID S_IRUSR S_IWUSR );
use Apache::AuthDigest::API;
use Digest::MD5;
use strict;

# $Id: AuthDigestDBI.pm,v 1.1 2002/11/11 13:58:37 geoff Exp $

require_version DBI 1.00;

$Apache::AuthDigestDBI::VERSION = '0.89';

# 1: report about cache miss
# 2: full debug output
$Apache::AuthDigestDBI::DEBUG = 0;


# configuration attributes, defaults will be overwritten with values from .htaccess.

my %Config = (
    'Auth_DBI_data_source'      => '',
    'Auth_DBI_username'         => '',
    'Auth_DBI_password'         => '',
    'Auth_DBI_pwd_table'        => '',
    'Auth_DBI_uid_field'        => '',
    'Auth_DBI_pwd_field'        => '',
    'Auth_DBI_pwd_whereclause'  => '',
    'Auth_DBI_grp_table'        => '',
    'Auth_DBI_grp_field'        => '',
    'Auth_DBI_grp_whereclause'  => '',
    'Auth_DBI_log_field'        => '',
    'Auth_DBI_log_string'       => '',
    'Auth_DBI_authoritative'    => 'on',
    'Auth_DBI_nopasswd'         => 'off',
    'Auth_DBI_encrypted'        => 'on',
    'Auth_DBI_encryption_salt'  => 'password',
    'Auth_DBI_uidcasesensitive' => 'on',
    'Auth_DBI_pwdcasesensitive' => 'on',
    'Auth_DBI_placeholder'      => 'off',
);

# stores the configuration of current URL.
# initialized  during authentication, eventually re-used for authorization.
my $Attr = { };


# global cache: all records are put into one string.
# record separator is a newline. Field separator is $;.
# every record is a list of id, time of last access, password, groups (authorization only).
# the id is a comma separated list of user_id, data_source, pwd_table, uid_field.
# the first record is a timestamp, which indicates the last run of the CleanupHandler followed by the child counter.

my $Cache = time . "$;0\n";

# unique id which serves as key in $Cache.
# the id is generated during authentication and re-used for authorization.
my $ID;


# minimum lifetimes of cache entries in seconds.
# setting the CacheTime to 0 will not use the cache at all.

my $CacheTime = 0;

# supposed to be called in a startup script.
# sets CacheTime to a user defined value.

sub setCacheTime {
    my $class      = shift;
    my $cache_time = shift;
    # sanity check
    $CacheTime = $cache_time if ($cache_time =~ /\d+/);
}


# minimum time interval in seconds between two runs of the PerlCleanupHandler.
# setting CleanupTime to 0 will run the PerlCleanupHandler after every request.
# setting CleanupTime to a negative value will disable the PerlCleanupHandler.

my $CleanupTime = -1;

# supposed to be called in a startup script.
# sets CleanupTime to a user defined value.

sub setCleanupTime {
    my $class        = shift;
    my $cleanup_time = shift;
    # sanity check
    $CleanupTime = $cleanup_time if ($cleanup_time =~ /\-*\d+/);
}


# optionally the string with the global cache can be stored in a shared memory segment.
# the segment will be created from the first child and it will be destroyed if the last child exits.
# the reason for not handling everything in the main server is simply, that there is no way to setup 
# an ExitHandler which runs in the main server and which would remove the shared memory and the semaphore.
# hence we have to keep track about the number of children, so that the last one can do all the cleanup.
# creating the shared memory in the first child also has the advantage, that we don't have to cope
# with changing the ownership.
# if a shm-function fails, the global cache will automatically fall back to one string per process.

my $SHMKEY  =     0; # unique key for shared memory segment and semaphore set
my $SEMID   =     0; # id of semaphore set
my $SHMID   =     0; # id of shared memory segment
my $SHMSIZE = 50000; # default size of shared memory segment

# shortcuts for semaphores
my $obtain_lock  = pack("sss", 0,  0, 0) . pack("sss", 0, 1, 0);
my $release_lock = pack("sss", 0, -1, 0);

# supposed to be called in a startup script.
# sets SHMSIZE to a user defined value and initializes the unique key, used for the shared memory segment and for the semaphore set.
# creates a PerlChildInitHandler which creates the shared memory segment and the semaphore set.
# creates a PerlChildExitHandler which removes the shared memory segment and the semaphore set upon server shutdown.
# keep in mind, that this routine runs only once, when the main server starts up.

sub initIPC {
    my $class   = shift;
    my $shmsize = shift;

    # make sure, this method is called only once
    return if $SHMKEY;

    # ensure minimum size of shared memory segment
    $SHMSIZE = $shmsize if $shmsize >= 500;

    # generate unique key based on path of AuthDBI.pm
    foreach my $file (keys %INC) {
        if ($file eq 'Apache/AuthDBI.pm') {
            $SHMKEY = IPC::SysV::ftok($INC{$file}, 1);
            last;
        }
    }

    # provide a handler which initializes the shared memory segment (first child)
    # or which increments the child counter. 
    if(Apache->can('push_handlers')) {
        Apache->push_handlers("PerlChildInitHandler" => \&childinit);
    }

    # provide a handler which decrements the child count or which destroys the shared memory 
    # segment upon server shutdown, which is defined by the exit of the last child.
    if(Apache->can('push_handlers')) {
        Apache->push_handlers("PerlChildExitHandler" => \&childexit);
    }
}


# authentication handler

sub authen {

    my ($r) = @_;
    my ($key, $val, $dbh);

    my $prefix = "$$ Apache::AuthDigestDBI::authen";

    if ($Apache::AuthDigestDBI::DEBUG > 1) {
        my ($type) = '';
        $type .= 'initial ' if $r->is_initial_req;
        $type .= 'main'     if $r->is_main;
        print STDERR "==========\n$prefix request type = >$type< \n";
    }

    return OK unless $r->is_initial_req; # only the first internal request

    print STDERR "REQUEST:\n", $r->as_string if $Apache::AuthDigestDBI::DEBUG > 1;
	
	my $auth = 'digest';

	# here the dialog pops up and asks you for username and password
	my ($status, $response, $res, $passwd_sent);
	if ($r->header_in("Authorization") =~ /^Basic (.*)/i) {
		$auth = 'Basic';
		my $username;
		($username, $passwd_sent) = split ':', old_decode_base64($1);
		$r->connection->user($username);
	}

	if ($auth eq 'digest') {

		$r = Apache::AuthDigest::API->new($r);
		($status, $response) = $r->get_digest_auth_response;		
		return $status unless $status == OK;
		$passwd_sent = 'digest';
		
	} else {
	
		#($res, $passwd_sent) = $r->get_basic_auth_pw;
		#print STDERR "$prefix get_basic_auth_pw: res = >$res<, password sent = >$passwd_sent<\n" if $Apache::AuthDigestDBI::DEBUG > 1;
		#return $res if $res; # e.g. HTTP_UNAUTHORIZED
		
		return AUTH_REQUIRED unless $passwd_sent;
		
	}

    # get username
    my ($user_sent) = $r->connection->user;
    print STDERR "$prefix user sent = >$user_sent<\n" if $Apache::AuthDigestDBI::DEBUG > 1;

    # do we use shared memory for the global cache ?
    print STDERR "$prefix cache in shared memory, shmid $SHMID, shmsize $SHMSIZE, semid $SEMID \n" if ($SHMID and $Apache::AuthDigestDBI::DEBUG > 1);

    # get configuration
    while(($key, $val) = each %Config) {
        $val = $r->dir_config($key) || $val;
        $key =~ s/^Auth_DBI_//;
        $Attr->{$key} = $val;
        printf STDERR "$prefix Config{ %-16s } = %s\n", $key, $val if $Apache::AuthDigestDBI::DEBUG > 1;
    }

    # parse connect attributes, which may be tilde separated lists
    my @data_sources = split(/~/, $Attr->{data_source});
    my @usernames    = split(/~/, $Attr->{username});
    my @passwords    = split(/~/, $Attr->{password});
    $data_sources[0] = '' unless $data_sources[0]; # use ENV{DBI_DSN} if not defined

    # obtain the id for the cache
    my $data_src = $Attr->{data_source};
    $data_src =~ s/\(.+\)//go; # remove any embedded attributes, because of trouble with regexps
    $ID = join ',', $user_sent, $data_src, $Attr->{pwd_table}, $Attr->{uid_field};

    # if not configured decline
    unless ($Attr->{pwd_table} && $Attr->{uid_field} && $Attr->{pwd_field}) {
        printf STDERR "$prefix not configured, return DECLINED\n" if $Apache::AuthDigestDBI::DEBUG > 1;
        return DECLINED;
    }

    # do we want Windows-like case-insensitivity?
    $user_sent   = lc($user_sent)   if $Attr->{uidcasesensitive} eq "off";
    $passwd_sent = lc($passwd_sent) if $Attr->{pwdcasesensitive} eq "off";

    # check whether the user is cached but consider that the password possibly has changed
    my $passwd = '';
    my $salt   = '';
    if ($CacheTime) { # do we use the cache ?
        if ($SHMID) { # do we keep the cache in shared memory ?
            semop($SEMID, $obtain_lock) or print STDERR "$prefix semop failed \n";
            shmread($SHMID, $Cache, 0, $SHMSIZE) or printf STDERR "$prefix shmread failed \n";
            substr($Cache, index($Cache, "\0")) = '';
            semop($SEMID, $release_lock) or print STDERR "$prefix semop failed \n";
        }
        # find id in cache
        my ($last_access, $passwd_cached, $groups_cached);
        if ($Cache =~ /$ID$;(\d+)$;(.+)$;(.*)\n/) {
            $last_access   = $1;
            $passwd_cached = $2;
            $groups_cached = $3;
            printf STDERR "$prefix cache: found >$ID< >$last_access< >$passwd_cached< \n" if $Apache::AuthDigestDBI::DEBUG > 1;
			if ($auth eq 'digest') {
				$salt = $response->{'realm'};
				my $passwd_to_check = Digest::MD5::md5_hex(join ':', $user_sent, $salt, $passwd_cached);
				$passwd = $passwd_cached if $r->compare_digest_response($response, $passwd_to_check);
			} else {
				$salt = $Attr->{encryption_salt} eq 'userid' ? $user_sent : $passwd_cached;
				my $passwd_to_check = $Attr->{encrypted} eq 'on' ? crypt($passwd_sent, $salt) : $passwd_sent; 
				# match cached password with password sent 
				$passwd = $passwd_cached if $passwd_to_check eq $passwd_cached;
			}
        }
    }

    if ($passwd) { # found in cache
        printf STDERR "$prefix passwd found in cache \n" if $Apache::AuthDigestDBI::DEBUG > 1;
    } else { # password not cached or changed
        printf STDERR "$prefix passwd not found in cache \n" if $Apache::AuthDigestDBI::DEBUG;

        # connect to database, use all data_sources until the connect succeeds
        my $j;
        for ($j = 0; $j <= $#data_sources; $j++) {
            last if ($dbh = DBI->connect($data_sources[$j], $usernames[$j], $passwords[$j]));
        }
        unless ($dbh) {
            $r->log_reason("$prefix db connect error with data_source >$Attr->{data_source}<", $r->uri);
            return SERVER_ERROR;
        }

        # generate statement
        my $user_sent_quoted = $dbh->quote($user_sent);
        my $select    = "SELECT $Attr->{pwd_field}";
        my $from      = "FROM $Attr->{pwd_table}";
        my $where     = ($Attr->{uidcasesensitive} eq "off") ? "WHERE lower($Attr->{uid_field}) =" : "WHERE $Attr->{uid_field} =";
        my $compare   = ($Attr->{placeholder}      eq "on")  ? "?" : "$user_sent_quoted";
        my $statement = "$select $from $where $compare";
        $statement   .= " AND $Attr->{pwd_whereclause}" if $Attr->{pwd_whereclause};
        print STDERR "$prefix statement: $statement\n" if $Apache::AuthDigestDBI::DEBUG > 1;

        # prepare statement
        my $sth;
        unless ($sth = $dbh->prepare($statement)) {
            $r->log_reason("$prefix can not prepare statement: $DBI::errstr", $r->uri);
            $dbh->disconnect;
            return SERVER_ERROR;
        }

        # execute statement
        my $rv;
        unless ($rv = ($Attr->{placeholder} eq "on") ? $sth->execute($user_sent) : $sth->execute) {
            $r->log_reason("$prefix can not execute statement: $DBI::errstr", $r->uri);
            $dbh->disconnect;
            return SERVER_ERROR;
        }

        # fetch result
        while ($_ = $sth->fetchrow_array) {
            # strip trailing blanks for fixed-length data-type
            $_ =~ s/ +$// if $_;
            # consider the case with many users sharing the same userid
	    $passwd .= "$_$;";
        }

        chop  $passwd if $passwd;
        undef $passwd if 0 == $sth->rows; # so we can distinguish later on between no password and empty password

        if ($sth->err) {
            $dbh->disconnect;
            return SERVER_ERROR;
        }
        $sth->finish;

        # re-use dbh for logging option below
        $dbh->disconnect unless ($Attr->{log_field} && $Attr->{log_string});
    }

    $r->subprocess_env(REMOTE_PASSWORDS => $passwd);
    print STDERR "$prefix passwd = >$passwd<\n" if $Apache::AuthDigestDBI::DEBUG > 1;

    # check if password is needed
    if (!defined($passwd)) { # not found in database
        # if authoritative insist that user is in database
        if ($Attr->{authoritative} eq 'on') {
            $r->log_reason("$prefix password for user $user_sent not found", $r->uri);
            $r->note_basic_auth_failure;
            return AUTH_REQUIRED;
        } else {
            # else pass control to the next authentication module
            return DECLINED;
        }
    }

    # allow any password if nopasswd = on and the retrieved password is empty
    if ($Attr->{nopasswd} eq 'on' && !$passwd) {
        return OK;
    }

    # if nopasswd is off, reject user
    unless ($passwd_sent && $passwd) {
        $r->log_reason("$prefix user $user_sent: empty password(s) rejected", $r->uri);
        $r->note_basic_auth_failure;
        return AUTH_REQUIRED;
    }

    # compare passwords
    my $found = 0;
    my $password;
    foreach $password (split(/$;/, $passwd)) {
        # compare the two passwords possibly crypting the password if needed
        my $did_match = 0;
		if ($auth eq 'digest') {
			$salt = $response->{'realm'};
			# password to check is in a reverse role from below
			# it's the correct password
			my $passwd_to_check = Digest::MD5::md5_hex(join ':', $user_sent, $salt, $password);
			$did_match = 1 if $r->compare_digest_response($response, $passwd_to_check);
		} else {
			$salt = $Attr->{encryption_salt} eq 'userid' ? $user_sent : $password;
			my $passwd_to_check = $Attr->{encrypted} eq 'on' ? crypt($passwd_sent, $password) : $passwd_sent;
            print STDERR "$prefix user $user_sent: > '$passwd_to_check' eq '$password' < \n" if $Apache::AuthDigestDBI::DEBUG > 1;
			$did_match = 1 if $passwd_to_check eq $password;
		}
		
        if ($did_match) {
            $found = 1;
            $r->subprocess_env(REMOTE_PASSWORD => $password);
            print STDERR "$prefix user $user_sent: password match for >$password< \n" if $Apache::AuthDigestDBI::DEBUG > 1;
            # update timestamp and cache userid/password if CacheTime is configured
            if ($CacheTime) { # do we use the cache ?
                if ($SHMID) { # do we keep the cache in shared memory ?
                    semop($SEMID, $obtain_lock) or print STDERR "$prefix semop failed \n";
                    shmread($SHMID, $Cache, 0, $SHMSIZE) or printf STDERR "$prefix shmread failed \n";
                    substr($Cache, index($Cache, "\0")) = '';
                }
                # update timestamp and password or append new record
                my $now = time;
                if (!($Cache =~ s/$ID$;\d+$;.*$;(.*)\n/$ID$;$now$;$password$;$1\n/)) {
		    $Cache .= "$ID$;$now$;$password$;\n";
                } else {
                }
                if ($SHMID) { # write cache to shared memory
                    shmwrite($SHMID, $Cache, 0, $SHMSIZE)  or printf STDERR "$prefix shmwrite failed \n";
                    semop($SEMID, $release_lock) or print STDERR "$prefix semop failed \n";
                }
            }
            last;
        }
    }
    unless ($found) {
        $r->log_reason("$prefix user $user_sent: password mismatch", $r->uri);
		if ($auth eq 'digest') {
			$r->note_digest_auth_failure;
		} else {
			$r->note_basic_auth_failure;		
		}
        return AUTH_REQUIRED;
    }

    # logging option
    if ($Attr->{log_field} && $Attr->{log_string}) {
        if (!$dbh) { # connect to database if not already done
            my ($j, $connect);
            for ($j = 0; $j <= $#data_sources; $j++) {
                if ($dbh = DBI->connect($data_sources[$j], $usernames[$j], $passwords[$j])) {
                    $connect = 1;
                    last;
                }
            }
            unless ($connect) {
                $r->log_reason("$prefix db connect error with $Attr->{data_source}", $r->uri);
                return SERVER_ERROR;
            }
        }
        my $user_sent_quoted = $dbh->quote($user_sent);
        my $statement = "UPDATE $Attr->{pwd_table} SET $Attr->{log_field} = $Attr->{log_string} WHERE $Attr->{uid_field}=$user_sent_quoted";
        print STDERR "$prefix statement: $statement\n" if $Apache::AuthDigestDBI::DEBUG > 1;
        unless ($dbh->do($statement)) {
            $r->log_reason("$prefix can not do statement: $DBI::errstr", $r->uri);
            $dbh->disconnect;
            return SERVER_ERROR;
        }
        $dbh->disconnect;
    }

    # Unless the cache or the CleanupHandler is disabled, the CleanupHandler is initiated 
    # if the last run was more than $CleanupTime seconds before. 
    # Note, that it runs after the request, hence it cleans also the authorization entries 
    if ($CacheTime and $CleanupTime >= 0) {
        my $diff = time - substr($Cache, 0, index($Cache, "$;"));
        print STDERR "$prefix secs since last CleanupHandler: $diff, CleanupTime: $CleanupTime \n" if $Apache::AuthDigestDBI::DEBUG > 1;
        if ($diff > $CleanupTime and Apache->can('push_handlers')) {
            print STDERR "$prefix push PerlCleanupHandler \n" if $Apache::AuthDigestDBI::DEBUG > 1;
            Apache->push_handlers("PerlCleanupHandler", \&cleanup);
        }
    }

    printf STDERR "$prefix return OK\n" if $Apache::AuthDigestDBI::DEBUG > 1;
    return OK;
}


# authorization handler, it is called immediately after the authentication

sub authz {

    my ($r) = @_;
    my ($key, $val, $dbh);

    my ($prefix) = "$$ Apache::AuthDigestDBI::authz ";

    if ($Apache::AuthDigestDBI::DEBUG > 1) {
        my ($type) = '';
        $type .= 'initial ' if $r->is_initial_req;
        $type .= 'main'     if $r->is_main;
        print STDERR "==========\n$prefix request type = >$type< \n";
    }

    return OK unless $r->is_initial_req; # only the first internal request

    my ($user_result)  = DECLINED;
    my ($group_result) = DECLINED;

    # get username
    my ($user_sent) = $r->connection->user;
    print STDERR "$prefix user sent = >$user_sent<\n" if $Apache::AuthDigestDBI::DEBUG > 1 ;

    # here we could read the configuration, but we re-use the configuration from the authentication

    # parse connect attributes, which may be tilde separated lists
    my @data_sources = split(/~/, $Attr->{data_source});
    my @usernames    = split(/~/, $Attr->{username});
    my @passwords    = split(/~/, $Attr->{password});
    $data_sources[0] = '' unless $data_sources[0]; # use ENV{DBI_DSN} if not defined

    # if not configured decline
    unless ($Attr->{pwd_table} && $Attr->{uid_field} && $Attr->{grp_field}) {
        printf STDERR "$prefix not configured, return DECLINED\n" if $Apache::AuthDigestDBI::DEBUG > 1;
        return DECLINED;
    }

    # do we want Windows-like case-insensitivity?
    $user_sent = lc($user_sent) if $Attr->{uidcasesensitive} eq "off";

    # select code to return if authorization is denied:
    my $authz_denied= $Attr->{expeditive} eq 'on' ? FORBIDDEN : AUTH_REQUIRED;

    # check if requirements exists
    my ($ary_ref) = $r->requires;
    unless ($ary_ref) {
        if ($Attr->{authoritative} eq 'on') {
            $r->log_reason("user $user_sent denied, no access rules specified (DBI-Authoritative)", $r->uri);
            $r->note_basic_auth_failure if $authz_denied == AUTH_REQUIRED;
            return $authz_denied;
        }
        printf STDERR "$prefix no requirements and not authoritative, return DECLINED\n" if $Apache::AuthDigestDBI::DEBUG > 1;
        return DECLINED;
    }

    # iterate over all requirement directives and store them according to their type (valid-user, user, group)
    my($hash_ref, $valid_user, $user_requirements, $group_requirements);
    foreach $hash_ref (@$ary_ref) {
        while (($key,$val) = each %$hash_ref) {
            last if $key eq 'requirement';
        }
        $val =~ s/^\s*require\s+//;
        # handle different requirement-types
        if ($val =~ /valid-user/) {
            $valid_user = 1;
        } elsif ($val =~ s/^user\s+//go) {
            $user_requirements .= " $val";
        } elsif ($val =~ s/^group\s+//go) {
            $group_requirements .= " $val";
        }
    }
    $user_requirements  =~ s/^ //go;
    $group_requirements =~ s/^ //go;
    print STDERR "$prefix requirements: valid-user=>$valid_user< user=>$user_requirements< group=>$group_requirements< \n"  if $Apache::AuthDigestDBI::DEBUG > 1;

    # check for valid-user
    if ($valid_user) {
        $user_result = OK;
        print STDERR "$prefix user_result = OK: valid-user\n" if $Apache::AuthDigestDBI::DEBUG > 1;
    }

    # check for users
    if ($user_result != OK && $user_requirements) {
        $user_result = AUTH_REQUIRED;
        my $user_required;
        foreach $user_required (split /\s+/, $user_requirements) {
            if ($user_required eq $user_sent) {
                print STDERR "$prefix user_result = OK for $user_required \n" if $Apache::AuthDigestDBI::DEBUG > 1;
                $user_result = OK;
                last;
           }
        }
    }

    # check for groups
    if ($user_result != OK && $group_requirements) {
        $group_result = AUTH_REQUIRED;
        my ($group, $group_required);

        # check whether the user is cached but consider that the group possibly has changed
        my $groups = '';
        if ($CacheTime) { # do we use the cache ?
            # we need to get the cached groups for the current id, which has been read already 
            # during authentication, so we do not read the Cache from shared memory again
            my ($last_access, $passwd_cached, $groups_cached);
            if ($Cache =~ /$ID$;(\d+)$;(.*)$;(.+)\n/) {
                $last_access   = $1;
                $passwd_cached = $2;
                $groups_cached = $3;
                printf STDERR "$prefix cache: found >$ID< >$last_access< >$groups_cached< \n" if $Apache::AuthDigestDBI::DEBUG > 1;
                REQUIRE_1: foreach $group_required (split /\s+/, $group_requirements) {
                    foreach $group (split(/,/, $groups_cached)) {
                        if ($group_required eq $group) {
                            $groups = $groups_cached;
                            last REQUIRE_1;
		        }
                    }
                }
            }
        }

        if ($groups) { # found in cache
            printf STDERR "$prefix groups found in cache \n" if $Apache::AuthDigestDBI::DEBUG > 1;
        } else { # groups not cached or changed
            printf STDERR "$prefix groups not found in cache \n" if $Apache::AuthDigestDBI::DEBUG;

            # connect to database, use all data_sources until the connect succeeds
            my ($j, $connect);
            for ($j = 0; $j <= $#data_sources; $j++) {
                if ($dbh = DBI->connect($data_sources[$j], $usernames[$j], $passwords[$j])) {
                    $connect = 1;
                    last;
                }
            }
            unless ($connect) {
                $r->log_reason("$prefix db connect error with $Attr->{data_source}", $r->uri);
                return SERVER_ERROR;
            }

            # generate statement
            my $user_sent_quoted = $dbh->quote($user_sent);
            my $select    = "SELECT $Attr->{grp_field}";
            my $from      = ($Attr->{grp_table}) ? "FROM $Attr->{grp_table}" : "FROM $Attr->{pwd_table}";
            my $where     = ($Attr->{uidcasesensitive} eq "off") ? "WHERE lower($Attr->{uid_field}) =" : "WHERE $Attr->{uid_field} =";
            my $compare   = ($Attr->{placeholder}      eq "on")  ? "?" : "$user_sent_quoted";
            my $statement = "$select $from $where $compare";
            $statement   .= " AND $Attr->{grp_whereclause}" if ($Attr->{grp_whereclause});
            print STDERR "$prefix statement: $statement\n" if $Apache::AuthDigestDBI::DEBUG > 1;

            # prepare statement
            my $sth;
            unless ($sth = $dbh->prepare($statement)) {
                $r->log_reason("can not prepare statement: $DBI::errstr", $r->uri);
                $dbh->disconnect;
                return SERVER_ERROR;
            }

            # execute statement
            my $rv;
            unless ($rv = ($Attr->{placeholder} eq "on") ? $sth->execute($user_sent) : $sth->execute) {
                $r->log_reason("can not execute statement: $DBI::errstr", $r->uri);
                $dbh->disconnect;
                return SERVER_ERROR;
            }

            # fetch result and build a group-list
            my $group;
            while ( $group = $sth->fetchrow_array ) {
                # strip trailing blanks for fixed-length data-type
                $group =~ s/ +$//;
                $groups .= "$group,";
            }
            chop $groups if $groups;

            $sth->finish;
            $dbh->disconnect;
        }

        $r->subprocess_env(REMOTE_GROUPS => $groups);
        print STDERR "$prefix groups = >$groups<\n" if $Apache::AuthDigestDBI::DEBUG > 1;

        # skip through the required groups until the first matches
        REQUIRE_2: foreach $group_required (split /\s+/, $group_requirements) {
            foreach $group (split(/,/, $groups)) {
                # check group
                if ($group_required eq $group) {
                    $group_result = OK;
                    $r->subprocess_env(REMOTE_GROUP => $group);
                    print STDERR "$prefix user $user_sent: group_result = OK for >$group< \n" if $Apache::AuthDigestDBI::DEBUG > 1;
                    # update timestamp and cache userid/groups if CacheTime is configured
                    if ($CacheTime) { # do we use the cache ?
                        if ($SHMID) { # do we keep the cache in shared memory ?
                            semop($SEMID, $obtain_lock) or print STDERR "$prefix semop failed \n";
                            shmread($SHMID, $Cache, 0, $SHMSIZE) or printf STDERR "$prefix shmread failed \n";
                            substr($Cache, index($Cache, "\0")) = '';
                        }
                        # update timestamp and groups
                        my $now = time;
                        # entry must exists from authentication
	        	$Cache =~ s/$ID$;\d+$;(.*)$;.*\n/$ID$;$now$;$1$;$groups\n/;
                        if ($SHMID) { # write cache to shared memory
                            shmwrite($SHMID, $Cache, 0, $SHMSIZE)  or printf STDERR "$prefix shmwrite failed \n";
                            semop($SEMID, $release_lock) or print STDERR "$prefix semop failed \n";
                        }
                    }
                    last REQUIRE_2;
		}
            }
        }
    }

    # check the results of the requirement checks
    if ($Attr->{authoritative} eq 'on' && $user_result != OK && $group_result != OK) {
        my $reason;
        $reason .= " USER"  if $user_result  == AUTH_REQUIRED;
        $reason .= " GROUP" if $group_result == AUTH_REQUIRED;
        $r->log_reason("DBI-Authoritative: Access denied on $reason rule(s)", $r->uri);
        $r->note_basic_auth_failure if $authz_denied == AUTH_REQUIRED;
        return $authz_denied;
    }

    # return OK if authorization was successful
    if ($user_result == OK || $group_result == OK) {
        printf STDERR "$prefix return OK\n" if $Apache::AuthDigestDBI::DEBUG > 1;
        return OK;
    }

    # otherwise fall through
    printf STDERR "$prefix fall through, return DECLINED\n" if $Apache::AuthDigestDBI::DEBUG > 1;
    return DECLINED;
}


# The PerlChildInitHandler initializes the shared memory segment (first child)
# or increments the child counter. 
# Note: this handler runs in every child server, but not in the main server.

sub childinit {
    my $prefix = "$$ Apache::AuthDigestDBI         PerlChildInitHandler";
    # create (or re-use existing) semaphore set
    $SEMID = semget($SHMKEY, 1, IPC_CREAT|S_IRUSR|S_IWUSR);
    if (!defined($SEMID)) {
      print STDERR "$prefix semget failed \n";
      return;
    }
    # create (or re-use existing) shared memory segment
    $SHMID = shmget($SHMKEY, $SHMSIZE, IPC_CREAT|S_IRUSR|S_IWUSR);
    if (!defined($SHMID)) {
      print STDERR "$prefix shmget failed \n";
      return;
    }
    # make ids accessible to other handlers
    $ENV{AUTH_SEMID} = $SEMID;
    $ENV{AUTH_SHMID} = $SHMID;
    # read shared memory, increment child count and write shared memory segment
    semop($SEMID, $obtain_lock) or print STDERR "$prefix semop failed \n";
    shmread($SHMID, $Cache, 0, $SHMSIZE) or printf STDERR "$prefix shmread failed \n";
    substr($Cache, index($Cache, "\0")) = '';
    my $child_count_new = 1;
    if ($Cache =~ /^(\d+)$;(\d+)\n/) { # segment already exists (eg start of additional server)
        my $time_stamp   = $1;
        my $child_count  = $2;
        $child_count_new = $child_count + 1;
        $Cache =~ s/^$time_stamp$;$child_count\n/$time_stamp$;$child_count_new\n/;
    } else { # first child => initialize segment
        $Cache = time . "$;$child_count_new\n";
    }
    print STDERR "$prefix child count = $child_count_new \n" if $Apache::AuthDigestDBI::DEBUG > 1;
    shmwrite($SHMID, $Cache, 0, $SHMSIZE) or printf STDERR "$prefix shmwrite failed \n";
    semop($SEMID, $release_lock) or print STDERR "$prefix semop failed \n";
    1;
}


# The PerlChildExitHandler decrements the child count or destroys the shared memory 
# segment upon server shutdown, which is defined by the exit of the last child.
# Note: this handler runs in every child server, but not in the main server.

sub childexit {
    my $prefix = "$$ Apache::AuthDigestDBI         PerlChildExitHandler";
    # read Cache from shared memory, decrement child count and exit or write Cache to shared memory
    semop($SEMID, $obtain_lock) or print STDERR "$prefix semop failed \n";
    shmread($SHMID, $Cache, 0, $SHMSIZE) or printf STDERR "$prefix shmread failed \n";
    substr($Cache, index($Cache, "\0")) = '';
    $Cache =~ /^(\d+)$;(\d+)\n/;
    my $time_stamp  = $1;
    my $child_count = $2;
    my $child_count_new = $child_count - 1;
    if ($child_count_new) {
        print STDERR "$prefix child count = $child_count \n" if $Apache::AuthDigestDBI::DEBUG > 1;
        # write Cache into shared memory
        $Cache =~ s/^$time_stamp$;$child_count\n/$time_stamp$;$child_count_new\n/;
        shmwrite($SHMID, $Cache, 0, $SHMSIZE) or printf STDERR "$prefix shmwrite failed \n";
        semop($SEMID, $release_lock) or print STDERR "$prefix semop failed \n";
    } else { # last child
        # remove shared memory segment and semaphore set
        print STDERR "$prefix child count = $child_count, remove shared memory $SHMID and semaphore $SEMID \n" if $Apache::AuthDigestDBI::DEBUG > 1;
        shmctl($SHMID,    IPC_RMID, 0) or print STDERR "$prefix shmctl failed \n";
        semctl($SEMID, 0, IPC_RMID, 0) or print STDERR "$prefix semctl failed \n";
    }
    1;
}


# The PerlCleanupHandler skips through the cache and deletes any outdated entry.
# Note: this handler runs after the response has been sent to the client.

sub cleanup {
    my $prefix = "$$ Apache::AuthDigestDBI         PerlCleanupHandler";
    print STDERR "$prefix \n" if $Apache::AuthDigestDBI::DEBUG > 1;
    my $now = time;
    if ($SHMID) { # do we keep the cache in shared memory ?
        semop($SEMID, $obtain_lock) or print STDERR "$prefix semop failed \n";
        shmread($SHMID, $Cache, 0, $SHMSIZE) or printf STDERR "$prefix shmread failed \n";
        substr($Cache, index($Cache, "\0")) = ''; 
    }
    my $newCache = "$now$;"; # initialize timestamp for CleanupHandler
    my ($time_stamp, $child_count);
    foreach my $record (split(/\n/, $Cache)) {
        if (!$time_stamp) { # first record: timestamp of CleanupHandler and child count
            ($time_stamp, $child_count) = split(/$;/, $record);
            $newCache .= "$child_count\n";
            next;
        }
        my ($id, $last_access, $passwd, $groups) = split(/$;/, $record);
        my $diff = $now - $last_access;
        if ($diff >= $CacheTime) {
            print STDERR "$prefix delete >$id<, last access $diff s before \n" if $Apache::AuthDigestDBI::DEBUG > 1;
        } else {
            print STDERR "$prefix keep   >$id<, last access $diff s before \n" if $Apache::AuthDigestDBI::DEBUG > 1;
            $newCache .= "$id$;$now$;$passwd$;$groups\n";
        }
    }
    $Cache = $newCache;
    if ($SHMID) { # write Cache to shared memory
        shmwrite($SHMID, $Cache, 0, $SHMSIZE) or printf STDERR "$prefix shmwrite failed \n";
        semop($SEMID, $release_lock) or print STDERR "$prefix semop failed \n";
    }
    1;
}

sub old_decode_base64 ($)
{
	local($^W) = 0; # unpack("u",...) gives bogus warning in 5.00[123]
	
	my $str = shift;
	$str =~ tr|A-Za-z0-9+=/||cd;            # remove non-base64 chars
	if (length($str) % 4) {
		require Carp;
		Carp::carp("Length of base64 data not a multiple of 4")
	}
	$str =~ s/=+$//;                        # remove padding
	$str =~ tr|A-Za-z0-9+/| -_|;            # convert to uuencoded format
	
	return join '', map( unpack("u", chr(32 + length($_)*3/4) . $_),
					$str =~ /(.{1,60})/gs);
}

1;

__END__