File Coverage

blib/lib/OpenInteract/Config.pm

Criterion	Covered	Total	%
statement	9	86	10.4
branch	0	22	0.0
condition	0	11	0.0
subroutine	3	14	21.4
pod	0	10	0.0
total	12	143	8.3

package OpenInteract::Config;

# $Id: Config.pm,v 1.7 2002/04/23 13:01:33 lachoy Exp $

use strict;
use OpenInteract::Error;
require Exporter;

# AUTOLOAD not being used any longer... see below
#use vars qw( $AUTOLOAD );
#$AUTOLOAD = '';

@OpenInteract::Config::ISA       = qw( Exporter );
$OpenInteract::Config::VERSION   = sprintf("%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/);
@OpenInteract::Config::EXPORT_OK = qw( _w DEBUG );
my %CONFIG_TYPES = (
   'perl' => 'OpenInteract::Config::PerlFile',
   'ini'  => 'OpenInteract::Config::IniFile',
);

use constant DEBUG => 0;

# Interface: subclasses should override these

sub read_config { return $_[0]; }
sub save_config { return undef; }


# Create a new config object. This is a factory method: rather than
# creating new objects of the class OpenInteract::Config, we use the
# variable $type and create an object based on it.

sub instance {
    my ( $pkg, $type, @params ) = @_;

    # Backwards compatibility fix -- this probably won't be here forever.

    $type ||= 'perl';
    my $class = $CONFIG_TYPES{ $type };
    die "No configuration class corresponding to type ($type)" unless ( $class );
    eval "require $class";
    if ( $@ ) {
        die "Configuration class ($class) cannot be used. Error: $@";
    }
    my $data = $class->read_config( @params );
    return bless( $data, $class );
}


sub read_file {
    my ( $class, $filename ) = @_;
    DEBUG && _w( 1, "Config trying to read file [$filename]" );
    open( CONF, $filename )
          || die "Cannot open [$filename] for reading: $!\n";
    my @lines = ;
    close( CONF );
    return \@lines;
}

# Copy items from the default action into all the other actions --
# this method doesn't quite belong here but since we don't have
# anything dealing strictly with action information... One possibility
# is to create a ActionTable module which does stuff like this and
# operates on $R

sub flatten_action_config {
    my ( $self ) = @_;
    my $default_action = $self->{action_info}{default} || $self->{action}{_default_action_info_};
    my @names = ();
    foreach my $action_key ( keys %{ $self->{action} } ) {
        next if ( $action_key eq 'default' or $action_key =~ /^_/ );
        foreach my $def ( keys %{ $default_action } ) {
            $self->{action}{ $action_key }{ $def } ||= $default_action->{ $def };
        }

        # Also ensure that the action information knows its own key

        $self->{action}{ $action_key }{name} = $action_key;
        push @names, $action_key;
    }
    return \@names;
}


# Set a parameter

sub param_set {
    my ( $self, $config, $value ) = @_;
    $config = lc $config;
    $self->{ $config } = $value if ( $value );
    return $self->{ $config };
}


# Get the value of a key

sub get {
    my ( $self, @p ) = @_;
    my @configs = ();
    foreach my $conf ( @p ) {
        push @configs, $self->param_set( $conf );
    }
    if ( scalar @configs == 1 ) {
        return $configs[0];
    }
    return @configs;
}


# Allow you to set multiple values at once

sub set {
    my ( $self, $p ) = @_;
    my %configs = ();
    my $count = 0;
    my $last_conf = '';           # hack to return one value if only one passed in
    foreach my $conf ( keys %{ $p } ) {
        $configs{ $conf } = $self->param_set( $conf, $p->{ $conf } );
        $last_conf = $conf;
        $count++;
    }
    if ( $count == 1 ) {
        return $configs{ $last_conf };
    }
    return %configs;
}


# Do a macro expansion on the directory names -- this SHOULD be done
# only once (on read, or by request) and then the information in the
# config object would be stable

sub get_dir {
    my ( $self, $dir_tag ) = @_;
    my $dir_hash = $self->{dir};
    $dir_tag =~ s/_dir$//;
    my $dir = $dir_hash->{ lc $dir_tag };
    DEBUG && _w( 1, "get_dir(): start out with <<$dir>>" );
    return undef if ( ! $dir );
    while ( $dir =~ m|^\$([\w\_]+)/| ) {
        my $orig_lookup = $1;
        my $lookup_dir = lc $orig_lookup;
        DEBUG && _w( 1, " get_dir(): found lookup dir of <<$lookup_dir>>" );
        return undef if ( ! $dir_hash->{ $lookup_dir } );
        $dir =~ s/^\$$orig_lookup/$dir_hash->{ $lookup_dir }/;
        DEBUG && _w( 1, " get_dir(): new directory: <<$dir>>" );
    }
    return $dir;
}



sub is_file_valid {
    my ( $self, $filename ) = @_;

    unless ( -f $filename ) {
        my $msg = 'Cannot read configuration file!';
        my $system_msg = "No valid filename ($filename) for reading configuration information!";
        OpenInteract::Error->set({ user_msg   => $msg,
                                   type       => 'config',
                                   system_msg => $system_msg,
                                   method     => 'read_config',
                                   extra      => { filename => $filename } });
        die $msg;
    }
    return 1;
}

# Allow you to call config keys as methods -- we should probably get
# rid of this and force you to use it as a hashref...

# AUTOLOAD no longer supported -- please email Chris if you have an
# issue with this.

#sub AUTOLOAD {
#  my ( $self, @params ) = @_;
#  my $request = $AUTOLOAD;
#  $request =~ s/.*://;
#  DEBUG && _w( 1, "Trying to fulfill request ($request) from AUTOLOAD" );
#  return $self->param_set( $request, @params);
#}


sub _w {
    return unless ( DEBUG >= shift );
    my ( $pkg, $file, $line ) = caller;
    my @ci = caller(1);
    warn "$ci[3] ($line) >> ", join( ' ', @_ ), "\n";
}

1;

__END__