view release on metacpan or  search on metacpan

lib/Config/Trivial/Storable.pm  view on Meta::CPAN

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