/usr/local/CPAN/Slauth/Slauth/Config.pm
# Slauth configuration
package Slauth::Config;
use strict;
use Data::Dumper;
#use warnings FATAL => 'all', NONFATAL => 'redefine';
our $debug = $ENV{SLAUTH_DEBUG};
#our $debug = 1;
sub debug { $debug; }
###########################################################################
# No user-servicable parts beyond this point
#
# Instead... use the Apache "SlauthConfig" directive (provided by
# Slauth::Config::Apache) or the SLAUTH_CONFIG environment variable
# to specify a Slauth configuration file.
#
# instantiate a new configuration object
sub new
{
my $class = shift;
my $self = {};
debug and print STDERR "debug: Slauth::Config: new\n";
# if an Apache request was provided, upgrade the object to
# Slauth::Config::Apache from the start so it's mod_perl-aware
debug and print STDERR "Slauth::Config::new: \$_[0] is ".
((defined $_[0]) ? "" : "not ")." present\n";
if ( debug and defined $_[0] ) {
print STDERR "Slauth::Config::new: \$_[0] is ".
ref( $_[0] )."\n";
print STDERR "Slauth::Config::new: ".
"isa('Apache::RequestRec') is ".
($_[0]->isa('Apache::RequestRec')
? "true" : "false" )."\n";
print STDERR "Slauth::Config::new: ".
"isa('Apache2::RequestRec') is ".
($_[0]->isa('Apache2::RequestRec')
? "true" : "false" )."\n";
}
if (( defined $_[0] ) and
( $_[0]->isa('Apache::RequestRec') or
$_[0]->isa('Apache2::RequestRec')))
{
eval "require Slauth::Config::Apache";
bless $self, "Slauth::Config::Apache";
} else {
bless $self, $class;
}
$self->initialize(@_);
return $self;
}
# initialize a Slauth::Config variable
# note: Slauth::Config::Apache has a separate initialize() function
# which will be used for objects blessed into its class
sub initialize
{
my $self = shift;
# allow SLAUTH_REALM from environment to set the request realm
if ( defined $ENV{SLAUTH_REALM}) {
$self->{realm} = $ENV{SLAUTH_REALM};
} elsif ( !defined $self->{realm}) {
$self->{realm} = "localhost";
}
# allow SLAUTH_CONFIG from environment to invoke the config file
if ( defined $ENV{SLAUTH_CONFIG}) {
my %config;
debug and print STDERR "debug: Slauth::Config: reading from ".$ENV{SLAUTH_CONFIG}." (from environment)\n";
eval $self->gulp($ENV{SLAUTH_CONFIG});
$config{realm} = $self->{realm};
$self->{config} = \%config;
# add "perl_inc" parameter to @INC
if ( defined $self->{config}{global}{perl_inc}) {
push @INC, @{$self->{config}{global}{perl_inc}};
}
} elsif ( -f "/etc/slauth/slauth.conf" ) {
my %config;
debug and print STDERR "debug: Slauth::Config: reading from /etc/slauth/slauth.conf (default)\n";
eval $self->gulp( "/etc/slauth/slauth.conf" );
$self->{config} = \%config;
}
$self->correct_realm_for_aliases();
# make a blank config if it wasn't already created
if ( ! defined $self->{config}) {
debug and print STDERR "debug: Slauth::Config: empty config\n";
$self->{config} = {};
$self->{config}{global} = {};
$self->{config}{$self->{realm}} = {};
}
}
# look up a config value
sub get
{
my ( $self, $key ) = @_;
my ( $res );
if ( $key eq "config" ) {
return $self;
}
if ( $key eq "realm" ) {
return $self->{realm};
}
$res = $self->get_indirect ( $self->{realm}, $key );
if ( !defined $res ) {
$res = $self->get_indirect ( "global", $key );
}
return $res;
}
# look up config entry with recursive redirection if necessary
# this function is intended to be called only by get() and itself
# use get() if you want to do any kind of config lookups
sub get_indirect
{
my ( $self, $conf_ref, $key, $stack ) = @_;
#debug and print STDERR "get_indirect ( $conf_ref, $key, $stack )\n";
# check that $conf_ref is not already on stack
my $i;
if ( !defined $stack ) {
# this relieves the initial call from responsibility to
# allocate the stack - it uses undef instead
$stack = [];
}
for ( $i=0; $i < @$stack; $i++ ) {
if ( $conf_ref eq $stack->[$i][0]) {
# prevent infinite loop
return undef;
}
}
push ( @$stack, [ $conf_ref, $key ]);
# perform indirection on lookup
my $c_type = ref $conf_ref;
if ( ! $c_type ) {
if ( defined $self->{config}{$conf_ref}) {
return $self->get_indirect(
$self->{config}{$conf_ref},
$key, $stack );
} else {
return undef;
}
} elsif ( $c_type eq "HASH" ) {
if ( $key eq "_conf" ) {
return $conf_ref;
} elsif ( $key eq "_realm" ) {
return $stack->[$#{@$stack}-1][0];
} elsif ( defined $conf_ref->{$key}) {
my $i_type = ref $conf_ref->{$key};
if ( ! $i_type ) {
# scalar is end value
return $conf_ref->{$key};
} elsif ( $i_type eq "ARRAY" ) {
my $indirect_type = $conf_ref->{$key}[0];
my $indirect_dest = $conf_ref->{$key}[1];
if ( $indirect_type eq "config" ) {
return $self->get_indirect(
$self->{config}{$indirect_dest},
$key, $stack );
}
} elsif ( $i_type eq "CODE" ) {
return &{$conf_ref->{$key}}($stack->[0][0]);
}
} else {
return undef;
}
}
}
# gulp read a configuration file into a string
sub gulp
{
my ( $self, $file ) = @_;
if ( open ( FILE, $file )) {
my @text = <FILE>;
close FILE;
return join ('', @text );
}
return undef;
}
# correct realm for any alias names it may represent
sub correct_realm_for_aliases
{
my $self = shift;
my $in_realm = $self->{realm};
debug and print STDERR "debug: "
."Slauth::Config::correct_realm_for_aliases: in: "
.$in_realm."\n";
debug and print STDERR Dumper($self->{config})."\n";
my $corrected_realm = $self->get( "_realm" );
debug and print STDERR "debug: "
."Slauth::Config::correct_realm_for_aliases: correction: "
.((defined $corrected_realm)?$corrected_realm:"undef")
."\n";
if ( defined $corrected_realm ) {
debug and print STDERR "debug: "
."Slauth::Config::correct_realm_for_aliases: "
."correcting realm from ".$in_realm
." to ".$corrected_realm."\n";
$self->{realm} = $corrected_realm;
$self->{config}{realm} = $self->{realm};
}
# with the config loaded, resolve any aliases for the realm
# it's an alias if the realm's name is a string which is the
# name of another realm
#if (( exists $self->{config}{$in_realm}) and
# ( !ref($self->{config}{$in_realm}))
# and ( exists $self->{config}{$self->{config}{$in_realm}}))
#{
# debug and print STDERR "debug: "
# ."Slauth::Config::correct_realm_for_aliases: "
# ."correcting realm from ".$in_realm
# ." to ".$self->{config}{$in_realm}."\n";
# $self->{realm} = $self->{config}{$in_realm};
# $self->{config}{realm} = $self->{realm};
#}
debug and print STDERR "debug: "
."Slauth::Config::correct_realm_for_aliases: out: "
.$self->{realm}."\n";
}
1;