File Coverage

blib/lib/Apache/AuthDBI.pm

Criterion	Covered	Total	%
statement	6	7	85.7
branch	1	2	50.0
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	9	11	81.8

package Apache::AuthDBI;

$Apache::AuthDBI::VERSION = '0.98';

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

use constant MP2 => $ENV{MOD_PERL_API_VERSION} == 2 ? 1 : 0;

BEGIN {
  my @constants = qw( OK AUTH_REQUIRED FORBIDDEN DECLINED SERVER_ERROR );
  if (MP2) {
    require Apache2::Const;
    import Apache2::Const @constants;
  }
  else {
    require Apache::Constants;
    import Apache::Constants @constants;
  }
}

use DBI ();
use Digest::SHA1;
use Digest::MD5;
use strict;

sub push_handlers {
  if ( MP2 ) {
		require Apache2::ServerUtil;
		my $s = Apache2::ServerUtil->server;
		$s->push_handlers(@_);
  }
  else {
    Apache->push_handlers(@_);
  }
}


# 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_encryption_method'=> 'sha1hex/md5/crypt',     #Using Two (or more) Methods Will Allow for Fallback to older Methods
    '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
my $SHMPROJID =   1; # default project id for shared memory segment

# Supposed to be called in a startup script.
# Sets SHMPROJID to a user defined value
sub setProjID {
    my $class        = shift;
    my $shmprojid = shift;

    #Set ProjID prior to calling initIPC!
    return if $SHMKEY;

    # sanity check - Must be numeric and less than or equal to 255
    $SHMPROJID = int($shmprojid) if ($shmprojid =~ /\d{1,3}/ && $shmprojid <= 255 && $shmprojid > 0);
}


# 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;
    require IPC::SysV;

    # 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 + SHMPROJID
    foreach my $file (keys %INC) {
        if ($file eq 'Apache/AuthDBI.pm') {
            $SHMKEY = IPC::SysV::ftok($INC{$file}, $SHMPROJID);
            last;
        }
    }

    # provide a handler which initializes the shared memory segment (first child)
    # or which increments the child counter.
    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.
    push_handlers( PerlChildExitHandler => \&childexit);
}


# authentication handler

sub authen {

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

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

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

    return MP2 ? Apache2::Const::OK() : Apache::Constants::OK() unless $r->is_initial_req; # only the first internal request

    print STDERR "REQUEST:\n", $r->as_string if $Apache::AuthDBI::DEBUG > 1;

    # here the dialog pops up and asks you for username and password
    my($res, $passwd_sent) = $r->get_basic_auth_pw;
    print STDERR "$prefix get_basic_auth_pw: res = >$res<, password sent = >$passwd_sent<\n" if $Apache::AuthDBI::DEBUG > 1;
    return $res if $res; # e.g. HTTP_UNAUTHORIZED

    # get username
    my ($user_sent) = $r->user;
    print STDERR "$prefix user sent = >$user_sent<\n" if $Apache::AuthDBI::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::AuthDBI::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::AuthDBI::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}) {
        print STDERR "$prefix not configured, return DECLINED\n" if $Apache::AuthDBI::DEBUG > 1;
        return MP2 ? Apache2::Const::DECLINED() : Apache::Constants::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 = '';
    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 print 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;
            print STDERR "$prefix cache: found >$ID< >$last_access< >$passwd_cached< \n" if $Apache::AuthDBI::DEBUG > 1;
            my (@passwds_to_check, $passwd_to_check);

            @passwds_to_check = &get_passwds_to_check($Attr, user_sent=>$user_sent, passwd_sent=>$passwd_sent, password=>$passwd_cached);

            print STDERR "$prefix ". scalar(@passwds_to_check) . " passwords to check\n" if $Apache::AuthDBI::DEBUG > 1;;
            foreach $passwd_to_check(@passwds_to_check) {
              # match cached password with password sent
              $passwd = $passwd_cached if $passwd_to_check eq $passwd_cached;
              if ($passwd) {
                last;
              }
            }
        }
    }

    if ($passwd) { # found in cache
        print STDERR "$prefix passwd found in cache \n" if $Apache::AuthDBI::DEBUG > 1;
    } else { # password not cached or changed
        print STDERR "$prefix passwd not found in cache \n" if $Apache::AuthDBI::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}<: $DBI::errstr", $r->uri);
            return MP2 ? Apache2::Const::SERVER_ERROR() : Apache::Constants::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::AuthDBI::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 MP2 ? Apache2::Const::SERVER_ERROR() : Apache::Constants::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 MP2 ? Apache2::Const::SERVER_ERROR() : Apache::Constants::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 MP2 ? Apache2::Const::SERVER_ERROR() : Apache::Constants::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::AuthDBI::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 MP2 ? Apache2::Const::AUTH_REQUIRED() : Apache::Constants::AUTH_REQUIRED();
        } else {
            # else pass control to the next authentication module
            return MP2 ? Apache2::Const::DECLINED() : Apache::Constants::DECLINED();
        }
    }

    # allow any password if nopasswd = on and the retrieved password is empty
    if ($Attr->{nopasswd} eq 'on' && !$passwd) {
        return MP2 ? Apache2::Const::OK() : Apache::Constants::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 MP2 ? Apache2::Const::AUTH_REQUIRED() : Apache::Constants::AUTH_REQUIRED();
    }

    # compare passwords
    my $found = 0;
    my $password;
    foreach $password (split(/$;/, $passwd)) {
        # compare all the passwords using as many encryption methods in fallback as needed
        my (@passwds_to_check, $passwd_to_check);

        @passwds_to_check = &get_passwds_to_check($Attr, user_sent=>$user_sent, passwd_sent=>$passwd_sent, password=>$password);

        print STDERR "$prefix ". scalar(@passwds_to_check) . " passwords to check\n" if $Apache::AuthDBI::DEBUG > 1;
        foreach $passwd_to_check(@passwds_to_check) {
          print STDERR "$prefix user $user_sent: Password after Preparation >$passwd_to_check< - trying for a match with >$password< \n" if $Apache::AuthDBI::DEBUG > 1;
          if ($passwd_to_check eq $password) {
            $found = 1;
            $r->subprocess_env(REMOTE_PASSWORD => $password);
            print STDERR "$prefix user $user_sent: Password from Web Server >$passwd_sent< - Password after Preparation >$passwd_to_check< - password match for >$password< \n" if $Apache::AuthDBI::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 print 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 print STDERR "$prefix shmwrite failed \n";
                    semop($SEMID, $release_lock) or print STDERR "$prefix semop failed \n";
                }
            }
            last;
          }
        }

        #if the passwd matched (encrypted or otherwise), don't check the myriad other passwords that may or may not exist
        if ($found > 0) {
            last;
        }
    }
    unless ($found) {
        $r->log_reason("$prefix user $user_sent: password mismatch", $r->uri);
        $r->note_basic_auth_failure;
        return MP2 ? Apache2::Const::AUTH_REQUIRED() : Apache::Constants::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 MP2 ? Apache2::Const::SERVER_ERROR() : Apache::Constants::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::AuthDBI::DEBUG > 1;
        unless ($dbh->do($statement)) {
            $r->log_reason("$prefix can not do statement: $DBI::errstr", $r->uri);
            $dbh->disconnect;
            return MP2 ? Apache2::Const::SERVER_ERROR() : Apache::Constants::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::AuthDBI::DEBUG > 1;
        if ($diff > $CleanupTime) {
            print STDERR "$prefix push PerlCleanupHandler \n" if $Apache::AuthDBI::DEBUG > 1;
            push_handlers( PerlCleanupHandler => \&cleanup);
        }
    }

    print STDERR "$prefix return OK\n" if $Apache::AuthDBI::DEBUG > 1;
    return MP2 ? Apache2::Const::OK() : Apache::Constants::OK();
}

#Encrypts a password in all supported/requested methods and passes back array for comparison
sub get_passwds_to_check {
  my ($Attr, %params) = @_;

  my ($prefix) = "$$ Apache::AuthDBI::get_passwds_to_check ";

  my ($salt, @passwds_to_check);

  if ($Attr->{encrypted} eq 'on') {
    #SHA1
    if ($Attr->{encryption_method} =~ /(^|\/)sha1hex($|\/)/i) {
      push (@passwds_to_check, &SHA1_digest(text=>$params{'passwd_sent'}, format=>'hex'));
    }
    #MD5
    if ($Attr->{encryption_method} =~ /(^|\/)md5hex($|\/)/i) {
      push (@passwds_to_check, &MD5_digest(text=>$params{'passwd_sent'}, format=>'hex'));
    }
    #CRYPT
    if ($Attr->{encryption_method} =~ /(^|\/)crypt($|\/)/i) {
      $salt = $Attr->{encryption_salt} eq 'userid' ? $params{'user_sent'} : $params{'password'};
      #Bug Fix in v0.94 (marked as 0.93 in file.  salt was NOT being sent to crypt) - KAM - 06-16-2005
      push (@passwds_to_check, crypt($params{'passwd_sent'}, $salt));
    }

    #WE DIDN'T GET ANY PASSWORDS TO CHECK.  MUST BE A PROBLEM
    if (scalar(@passwds_to_check) < 1) {
      print STDERR "$prefix Error: No Valid Encryption Method Specified.\n" if $Apache::AuthDBI::DEBUG > 1;
    }
  } else {
    #IF NO ENCRYPTION, JUST PUSH THE CLEARTEXT PASS
    push (@passwds_to_check, $params{'passwd_sent'});
  }

  return (@passwds_to_check);
}

# authorization handler, it is called immediately after the authentication
sub authz {

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

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

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

    unless ($r->is_initial_req) {
      return MP2 ? Apache2::Const::OK() : Apache::Constants::OK();
    }; # only the first internal request

    my ($user_result)  = MP2 ? Apache2::Const::DECLINED() : Apache::Constants::DECLINED();
    my ($group_result) = MP2 ? Apache2::Const::DECLINED() : Apache::Constants::DECLINED();

    # get username
    my ($user_sent) = $r->user;
    print STDERR "$prefix user sent = >$user_sent<\n" if $Apache::AuthDBI::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}) {
        print STDERR "$prefix not configured, return DECLINED\n" if $Apache::AuthDBI::DEBUG > 1;
        return MP2 ? Apache2::Const::DECLINED() : Apache::Constants::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);
    if (MP2) {
      $authz_denied = $Attr->{expeditive} eq 'on' ? Apache2::Const::FORBIDDEN() : Apache2::Const::AUTH_REQUIRED();
    } else {
      $authz_denied = $Attr->{expeditive} eq 'on' ? Apache::Constants::FORBIDDEN() : Apache::Constants::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);
            if ($authz_denied == MP2 ? Apache2::Const::AUTH_REQUIRED() : Apache::Constants::AUTH_REQUIRED()) {
              $r->note_basic_auth_failure;
            }
            return $authz_denied;
        }
        print STDERR "$prefix no requirements and not authoritative, return DECLINED\n" if $Apache::AuthDBI::DEBUG > 1;
        return MP2 ? Apache2::Const::DECLINED() : Apache::Constants::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::AuthDBI::DEBUG > 1;

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

    # check for users
    if (($user_result != MP2 ? Apache2::Const::OK() : Apache::Constants::OK()) && $user_requirements) {
        $user_result = MP2 ? Apache2::Const::AUTH_REQUIRED() : Apache::Constants::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::AuthDBI::DEBUG > 1;
                $user_result = MP2 ? Apache2::Const::OK() : Apache::Constants::OK();
                last;
           }
        }
    }

    # check for groups
    if (($user_result != MP2 ? Apache2::Const::OK() : Apache::Constants::OK()) && $group_requirements) {
        $group_result = MP2 ? Apache2::Const::AUTH_REQUIRED() : Apache::Constants::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;
                print STDERR "$prefix cache: found >$ID< >$last_access< >$groups_cached< \n" if $Apache::AuthDBI::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
            print STDERR "$prefix groups found in cache \n" if $Apache::AuthDBI::DEBUG > 1;
        } else { # groups not cached or changed
            print STDERR "$prefix groups not found in cache \n" if $Apache::AuthDBI::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 MP2 ? Apache2::Const::SERVER_ERROR() : Apache::Constants::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::AuthDBI::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 MP2 ? Apache2::Const::SERVER_ERROR() : Apache::Constants::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 MP2 ? Apache2::Const::SERVER_ERROR() : Apache::Constants::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::AuthDBI::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 = MP2 ? Apache2::Const::OK() : Apache::Constants::OK();
                    $r->subprocess_env(REMOTE_GROUP => $group);
                    print STDERR "$prefix user $user_sent: group_result = OK for >$group< \n" if $Apache::AuthDBI::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 print 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 print 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 != MP2 ? Apache2::Const::OK() : Apache::Constants::OK()) && ($group_result != MP2 ? Apache2::Const::OK() : Apache::Constants::OK())) {
        my $reason;
        if ($user_result == MP2 ? Apache2::Const::AUTH_REQUIRED() : Apache::Constants::AUTH_REQUIRED()) {
          $reason .= " USER";
        }
        if ($group_result == MP2 ? Apache2::Const::AUTH_REQUIRED() : Apache::Constants::AUTH_REQUIRED()) {
          $reason .= " GROUP";
        }
        $r->log_reason("DBI-Authoritative: Access denied on $reason rule(s)", $r->uri);

        if ($authz_denied == MP2 ? Apache2::Const::AUTH_REQUIRED() : Apache::Constants::AUTH_REQUIRED()) {
          $r->note_basic_auth_failure;
        }
        return $authz_denied;
    }

    # return OK if authorization was successful
    if (($user_result == MP2 ? Apache2::Const::OK() : Apache::Constants::OK()) || ($group_result == MP2 ? Apache2::Const::OK() : Apache::Constants::OK())) {
        print STDERR "$prefix return OK\n" if $Apache::AuthDBI::DEBUG > 1;
        return MP2 ? Apache2::Const::OK() : Apache::Constants::OK();
    }

    # otherwise fall through
    print STDERR "$prefix fall through, return DECLINED\n" if $Apache::AuthDBI::DEBUG > 1;
    return MP2 ? Apache2::Const::DECLINED() : Apache::Constants::DECLINED();
}


sub dec2hex($) {
    my ($dec) = @_;

    return sprintf("%lx", $dec );
}

# 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::AuthDBI         PerlChildInitHandler";
    # create (or re-use existing) semaphore set

    my ($SHMKEY_hex);

    $SHMKEY_hex = &dec2hex($SHMKEY);

    print STDERR "$prefix SHMProjID = >$SHMPROJID< Shared Memory Key >$SHMKEY Decimal - $SHMKEY_hex Hex<\n" if $Apache::AuthDBI::DEBUG > 1;

    $SEMID = semget($SHMKEY, 1,
		    IPC::SysV::IPC_CREAT() | IPC::SysV::S_IRUSR() | IPC::SysV::S_IWUSR());
    if (!defined($SEMID)) {
      print STDERR "$prefix semget failed - SHMKEY $SHMKEY - Error $!\n";
      if (uc(chomp($!)) eq 'PERMISSION DENIED') {
        print STDERR " $prefix Read/Write Permission Denied to Shared Memory Array.\n";
        print STDERR " $prefix Use ipcs -s to list semaphores and look for $SHMKEY_hex. If found, shutdown Apache and use ipcrm sem $SHMKEY_hex to remove the colliding (and hopefully unused) semaphore.  See documentation for setProjID for more information. \n";
      }
      return;

    }

    # create (or re-use existing) shared memory segment
    $SHMID = shmget($SHMKEY, $SHMSIZE,
		    IPC::SysV::IPC_CREAT() | IPC::SysV::S_IRUSR() | IPC::SysV::S_IWUSR());
    if (!defined($SHMID)) {
      print STDERR "$prefix shmget failed - Error $!\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 print 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::AuthDBI::DEBUG > 1;
    shmwrite($SHMID, $Cache, 0, $SHMSIZE) or print 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::AuthDBI         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 print 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::AuthDBI::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 print 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::AuthDBI::DEBUG > 1;
        shmctl($SHMID,    IPC::SysV::IPC_RMID(), 0) or print STDERR "$prefix shmctl failed \n";
        semctl($SEMID, 0, IPC::SysV::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::AuthDBI         PerlCleanupHandler";
    print STDERR "$prefix \n" if $Apache::AuthDBI::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 print 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::AuthDBI::DEBUG > 1;
        } else {
            print STDERR "$prefix keep   >$id<, last access $diff s before \n" if $Apache::AuthDBI::DEBUG > 1;
            $newCache .= "$id$;$now$;$passwd$;$groups\n";
        }
    }
    $Cache = $newCache;
    if ($SHMID) { # write Cache to shared memory
        shmwrite($SHMID, $Cache, 0, $SHMSIZE) or print STDERR "$prefix shmwrite failed \n";
        semop($SEMID, $release_lock) or print STDERR "$prefix semop failed \n";
    }
    1;
}

# Added 06-14-2005 - KAM - Returns SHA1 digest - Modified from PerlCMS' more generic routine to remove IO::File requirement
sub SHA1_digest {
  my $prefix = "$$ Apache::AuthDBI         SHA1_digest";
  print STDERR "$prefix \n" if $Apache::AuthDBI::DEBUG > 1;
  my (%params) = @_;
  my ($sha1);

  $params{'format'} ||= "base64";

  $sha1 = Digest::SHA1->new;

  if ($params{'text'} ne '') {
    $sha1->add($params{'text'});
  } else {
    return -1;
  }

  if ($params{'format'} =~ /base64/i) {
    return $sha1->b64digest;
  } elsif ($params{'format'} =~ /hex/i) {
    return $sha1->hexdigest;
  } elsif ($params{'format'} =~ /binary/i) {
    return $sha1->binary;
  }

  return -1;
}

# Added 06-20-2005 - KAM - Returns MD5 digest - Modified from PerlCMS' more generic routine to remove IO::File requirement
sub MD5_digest {
  my $prefix = "$$ Apache::AuthDBI         MD5_digest";
  print STDERR "$prefix \n" if $Apache::AuthDBI::DEBUG > 1;
  my (%params) = @_;
  my ($md5);

  $params{'format'} ||= "hex";

  $md5 = Digest::MD5->new;

  if ($params{'text'} ne '') {
    $md5->add($params{'text'});
  } else {
    return -1;
  }

  if ($params{'format'} =~ /base64/i) {
    return $md5->b64digest;
  } elsif ($params{'format'} =~ /hex/i) {
    return $md5->hexdigest;
  } elsif ($params{'format'} =~ /binary/i) {
    return $md5->digest;
  }

  return -1;
}

1;

__END__