File Coverage

blib/lib/Config/Trivial/Storable.pm

Criterion	Covered	Total	%
statement	66	67	98.5
branch	32	36	88.8
condition	36	45	80.0
subroutine	10	10	100.0
pod	3	3	100.0
total	147	161	91.3

#   $Id: Storable.pm 69 2014-05-23 10:27:30Z adam $

package Config::Trivial::Storable;

use base qw( Config::Trivial );

use 5.010;
use strict;
use Carp;
use warnings;
use Storable qw(lock_store lock_retrieve);

our $VERSION = '0.32';
my ( $_package, $_file ) = caller;

#
#   STORE
#

sub store {
    my $self = shift;
    my %args = @_;

    my $file = $args{'config_file'}
        || $self->{_storable_file}
        || $self->{_config_file};

    if ( (   ( $self->{_self} )
          && ( ( $file =~ '\(eval ' ) || ( $file =~ 'base.pm' ) ) )
        || ( $_file eq $file )
        || ( $0     eq $file ) )
    {
        return $self->_raise_error(
            'Not allowed to store to the calling file.');
    }

    if ( -e $file ) {
        croak "ERROR: Insufficient permissions to write to: $file"
            unless ( -w $file );
        rename $file, $file . $self->{_backup_char}
            or croak "ERROR: Unable to rename $file.";
    }

    my $settings = $args{'configuration'} || $self->{_configuration};

    if ( ! ( $settings && ref $settings eq 'HASH') ) {
        return $self->_raise_error(
            q{Configuration object isn't a HASH reference.})
    };

    lock_store $settings, $file or croak "Unable to store to $file";

    return 1;
}

#
#   RETRIEVE
#

sub retrieve {
    my $self = shift;
    my $key  = shift;    # If there is a key, return only it's value
    my $retrieved_hash_ref;
    my $file;

    if ( $self->{_config_file} && $self->{_storable_file} ) {
        if ( $self->{_config_file} eq $self->{_storable_file} ) {
            $file = $self->{_config_file};
        }
        elsif ( ( stat $self->{_config_file} )[9]
            > ( stat $self->{_storable_file} )[9] )
        {
            return $self->read($key) if $key;
            return $self->read;
        }
        else {
            $file = $self->{_storable_file};
        }
    }
    else {
        if ( $self->{_storable_file} ) {
            $file = $self->{_storable_file};
        }
        else {
            no warnings qw( uninitialized );
            if ((      ( $self->{_self} )
                    && ( defined $self->{_config_file} )
                    && (  ( $self->{_config_file} =~ '\(eval ' )
                       || ( $self->{_config_file} =~ 'base.pm' ) )
                )
                || ( $_file eq $self->{_config_file} )
                || ( $0     eq $self->{_config_file} )
                )
            {
                return $self->_raise_error(
                    q{Can't retrieve store from the calling file.});
            }
            $file = $self->{_config_file};
        }
    }

    return unless $self->_check_file($file);

    eval { $retrieved_hash_ref = lock_retrieve($file); };

    if ($@) {
        croak "ERROR: $@";
    }

    if ( ! ( $retrieved_hash_ref && ref $retrieved_hash_ref eq 'HASH') ) {
        return $self->_raise_error(
            q{Retrieved object isn't a HASH reference.})
    };

    $self->{_configuration} = $retrieved_hash_ref;

    return $self->{_configuration}->{$key} if $key;
    return $self->{_configuration};
}

#
#   SET STORABLE FILE
#

sub set_storable_file {
    my $self               = shift;
    my $configuration_file = shift;

    if ( $self->_check_file( $configuration_file ) ) {
        $self->{_storable_file} = $configuration_file;
        $self->{_self}          = 0;
        if ( ( $self->{_config_file} =~ '\(eval ' )
                ||  ($self->{_config_file} =~ 'base.pm' ) ) {
            delete $self->{_config_file};
        }
        return $self;
    }
    else {
        return;
    }
}

1;

__END__