view release on metacpan or  search on metacpan

lib/Apache2/AuthCookieDBImg.pm  view on Meta::CPAN

    require Crypt::CBC if ( $c{ DBI_encryptiontype } ne 'none' );

    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;
}

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

sub _percent_encode($)
{
    my( $str ) = @_;
    $str =~ s/([^\w])/ uc sprintf '%%%02x', ord $1 /eg;
    return $str;
}

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

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

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

=head1 SUBCLASSING

You can subclass this module to override public functions and change
their behaviour.

=over 4

=item C<extra_session_info()>

This method returns extra fields to add to the session key.
It should return a string consisting of ":field1:field2:field3"
(where each field is preceded by a colon).

The default implementation does nothing.

=back

=cut

sub extra_session_info ($$\@) {
    my ($self, $r, @credentials) = @_;
    return '';
}

#-------------------------------------------------------------------------------
# Take the credentials for a user and check that they match; if so, return
# a new session key for this user that can be stored in the cookie.
# If there is a problem, return a bogus session key.

sub authen_cred($$\@)
{
    my( $self, $r, @credentials ) = @_;

    my $auth_name = $r->auth_name;

    # Username goes in credential_0
    my $user = shift @credentials;
    unless ( $user =~ /^.+$/ ) {
        $r->log_error( "Apache2::AuthCookieDBI: no username supplied for auth realm $auth_name", $r->uri );
        return undef;
    }
    # Password goes in credential_1
    my $password = shift @credentials;
    unless ( $password =~ /^.+$/ ) {
        $r->log_error( "Apache2::AuthCookieDBI: no password supplied for auth realm $auth_name", $r->uri );
        return undef;
    }

	 # CSA Patch - Use global var
	 # needed later for authen_sess_key
	 # to keep cookie alive
	 #
    # Extra data can be put in credential_2, _3, etc.
    # my @extra_data = @credentials;
	 @Extra_Data = @credentials;

    # get the configuration information.
    my %c = _dbi_config_vars $r;

    # get the crypted password from the users database for this user.
    my $dbh = DBI->connect( $c{ DBI_DSN },
                            $c{ DBI_user }, $c{ DBI_password } );
    unless ( defined $dbh ) {
        $r->log_error( "Apache2::AuthCookieDBI: couldn't connect to $c{ DBI_DSN } for auth realm $auth_name", $r->uri );
        return undef;
    }
    my $sth = $dbh->prepare( <<"EOS" );
SELECT $c{ DBI_passwordfield }
FROM $c{ DBI_userstable }
WHERE $c{ DBI_userfield } = ?
EOS
    $sth->execute( $user );

    # CSA Patch - No need to add array overhead when fetching a single field
    # my( $crypted_password ) = $sth->fetchrow_array;
    my $crypted_password = $sth->fetchrow;
    unless ( defined $crypted_password ) {
        $r->log_error( "Apache2::AuthCookieDBI: couldn't select password from $c{ DBI_DSN }, $c{ DBI_userstable }, $c{ DBI_userfield } for user $user for auth realm $auth_name", $r->uri );
        return undef;
    }
   
    # now return unless the passwords match.
    if ( lc $c{ DBI_crypttype } eq 'none' ) {
        unless ( $password eq $crypted_password ) {
            $r->log_error( "Apache2::AuthCookieDBI: plaintext passwords didn't match for user $user for auth realm $auth_name", $r->uri );
            return undef;
        }
    } elsif ( lc $c{ DBI_crypttype } eq 'crypt' ) {
        my $salt = substr $crypted_password, 0, 2;
        unless ( crypt( $password, $salt ) eq $crypted_password ) {
            $r->log_error( "Apache2::AuthCookieDBI: crypted passwords didn't match for user $user for auth realm $auth_name", $r->uri );
            return undef;
        }
    } elsif ( lc $c{ DBI_crypttype } eq 'md5' ) {
        unless ( md5_hex( $password ) eq $crypted_password ) {
            $r->log_error( "Apache2::AuthCookieDBI: MD5 passwords didn't match for user $user for auth realm $auth_name", $r->uri );
            return undef;
        }
    }

    # CSA Patch - New gen_key function for activity reset
	 # on cookies
    #
    return $self->gen_key($r, $user, \@Extra_Data);
}

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

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

    my $auth_name = $r->auth_name;