view release on metacpan or  search on metacpan

lib/Pickles/Config.pm  view on Meta::CPAN

use Plack::Util::Accessor qw(appname home);
use Pickles::Util qw(env_value);

sub new {
    my $class = shift;
    my %args = @_;
    my $self = bless {}, $class;
    $self->{appname} = Pickles::Util::appname( $class );
    $self->setup_home( $args{home} );
    $self->{ACTION_PREFIX} = '';
    $self->load_files( $args{files} || [] );
    $self;
}

sub construct {
    my $class = shift;
    my $self = $class->new;
    my $files = $self->get_config_files;
    $self->load_files( $files );
    $self;
}

sub get {
    my( $self, $key, $default ) = @_;
    return defined $self->{$key} ? $self->{$key} : $default;
}

sub setup_home {
    my( $self, $home ) = @_;
    my $dir = 
        $home || env_value( 'HOME', $self->appname ) || $ENV{'PICKLES_HOME'};
    if ( $dir ) {
        $self->{home} = dir( $dir );
    }
    else {
        my $class = ref $self;
        (my $file = "$class.pm") =~ s|::|/|g;
        if (my $inc_path = $INC{$file}) {
            (my $path = $inc_path) =~ s/$file$//;
            my $home = dir($path)->absolute->cleanup;
            $home = $home->parent while $home =~ /b?lib$/;
            $self->{home} = $home;
        }
    }
}

sub load_files {
    my( $self, $files ) = @_;
    my %config;

    # In 5.8.8 at least, putting $self in an evaled code produces
    # extra warnings (and possibly break the behavior of __path_to)
    # so we create a private closure, and plant the closure into
    # the generated packes
    $self->{__FILES} = [];

    my $path_to = sub { $self->path_to(@_) };
    my $load_file = sub {
        my $file = $path_to->( @_ );
        delete $INC{$file};
        my $subconf = require $file;
        # death context should be at the calling config file level
        Carp::croak("Could not parse $file: $@") if $@;
        Carp::croak("Could not do $file: $!")    if ! defined $subconf;
        Carp::croak("Could not run $file")       if ! $subconf;

        push @{$self->{__FILES}}, $file;
        return $subconf;
    };

    for my $file( @{$files} ) {
        # only do this if the file exists
        next unless -e $file;

        my $pkg = $file;
        $pkg =~ s/([^A-Za-z0-9_])/sprintf("_%2x", unpack("C", $1))/eg;

        my $fqname = sprintf '%s::%s', ref $self, $pkg;
        { # XXX This is where we plant that closure
            no strict 'refs';
            no warnings 'redefine';
            *{"$fqname\::__path_to"} = $path_to;
            *{"$fqname\::load_file"} = $load_file;
        }

        my $config_pkg = sprintf <<'SANDBOX', $fqname;
package %s;
{
    my $conf = require $file or die $!;
    $conf;
}
SANDBOX
        delete $INC{$file};
        my $conf = eval $config_pkg || +{};
        if ($@) {
            warn "Error while trying to read config file $file: $@";
        }
        %config = (
            %config,
            %{$conf},
        );
    }
    push @{$self->{__FILES}}, @$files;
    $self->{__TIME} = time;
    for my $key( keys %config ) {
        $self->{$key} = $config{$key};
    }
    \%config;
}

sub get_config_files {
    my $self = shift;
    my @files;

    if ( my $config_file = env_value('CONFIG', $self->appname) ) {
        push @files, $self->path_to( $config_file );
    }
    else {
        my @base_files = ( File::Spec->catfile('etc', 'config.pl'), 'config.pl' );
        foreach my $f (@base_files) {
            my $base = $self->path_to($f);
            push @files, $base if -e $base;
        }
    }
    
    if ( my $env = env_value('ENV', $self->appname) ) {
        my @env_files;
        for my $file( @files ) {
            my ($v, $d, $fname) = File::Spec->splitpath( $file );
            $fname =~ s/(\.[^\.]+)?$/$1 ? "_%s$1" : "%s"/e;
            my $template = File::Spec->catpath( $v, $d, $fname );
            my $filename = sprintf $template, $env;
            push @env_files, $self->path_to( $filename );

        }
        push @files, @env_files;
    }
    return \@files;
}

sub path_to {
    my( $self, @path ) = @_;
    if ( File::Spec->file_name_is_absolute( $path[0] ) ) {
        return File::Spec->catfile( @path );
    }
    file( $self->home, @path )->stringify;
}

1;