view release on metacpan or  search on metacpan

lib/Apache2_4/AuthCookieMultiDBI.pm  view on Meta::CPAN

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

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

#-------------------------------------------------------------------------------
# _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 ($self, $r) = @_;

    Carp::confess('Failed to pass Apache request object') if not $r;

    my ( $pkg, $file, $line, $sub ) = caller(1);
    my $info_message = "${self} -> _dbi_connect called in $sub at line $line";
    $r->server->log_error( $info_message );

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

    my $auth_name = $r->auth_name;

    # 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 ) {
        my $error_message = "${self} => couldn't connect to $c{'DBI_DSN'} for auth realm $auth_name";
        $r->server->log_error( $error_message );
        return;
    }
    
    if($c{'DBI_LoadClientDB'}) {

        my $client = $self->get_client_name($r);
        $dbh = $self->_dbi_connect_to_client($r, $client);

    }

    if ( defined $dbh ) {
        my $info_message = "${self} => connect to $c{'DBI_DSN'} for auth realm $auth_name";
        $r->server->log_error( $info_message );
        return $dbh;
    }
    
}

#-------------------------------------------------------------------------------
# _dbi_connect_to_client -- Get a database handle for client database.
# 
sub _dbi_connect_to_client {
    my ($self, $r, $client) = @_;

    my $auth_name = $r->auth_name;

    my %c = $self->get_client_database_info($r, $client);

    $r->server->log_error("dbhost = $c{'dbhost'}; dbname = $c{'dbname'}; dblogin = $c{'dblogin'}; dbpass = $c{'dbpass'}:");

    my $dbi_dns = "DBI:mysql:database=$c{'dbname'}:host=$c{'dbhost'}";
    my $dbh = DBI->connect_cached( $dbi_dns, $c{'dblogin'}, $c{'dbpass'});

    if ( !defined $dbh ) {
        my $error_message = "${self} => couldn't connect to $c{'DBI_DSN'} for auth realm $auth_name";
        $r->server->log_error( $error_message );
        return;
    }

    return $dbh;
}


#-------------------------------------------------------------------------------
# _get_crypted_password -- Get the users' password from the database
# 
sub _get_crypted_password ($$\@) {
    my $self = shift;