File Coverage

lib/Hash/Persistent.pm

Criterion	Covered	Total	%
statement	22	24	91.6
branch			n/a
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	30	32	93.7

package Hash::Persistent;

our $VERSION = '1.01'; # VERSION
# ABSTRACT: nested hashref serializable to the file


use strict;
use warnings;

use autodie qw( open close chmod rename );

use Data::Dumper;
use Storable qw(thaw nfreeze);
use JSON;
use Carp;

use Lock::File 1.01 qw(lockfile);

my %defaults = (
    read_only => 0,
    auto_commit => 0,
    format => 'auto',
    lock => 1,
    write_only => 0,
);

my $meta = {};

sub new {
    my $class = shift;
    my ($fname, $options, $lock_options) = @_;

    $lock_options ||= {};

    $options ||= {};
    my $_self = {%defaults, %$options};

    if ($options->{read_only} and $options->{auto_commit}) {
        croak "Only one of 'read_only' and 'auto_commit' options can be true";
    }

    if ($_self->{read_only}) {
        $_self->{auto_commit} = 0;
        $_self->{lock} = 0;
    }

    if ($_self->{lock}) {
        $lock_options = $_self->{lock} if ref $_self->{lock};
        my $lock = lockfile("$fname.lock", { mode => $_self->{mode}, blocking => 1, remove => 1, %$lock_options });
        unless (defined $lock) {
            return;
        }
        $_self->{lock} = $lock;
    }
    $_self->{fname} = $fname;

    my $self;
    if (-e $fname and not $_self->{write_only}) {
        open my $fh, '<', $fname;
        my $data;
        local $/;
        my $str = <$fh>;
        if ($str =~ m{^\$data = }) {
            eval $str;
            die "Can't eval $fname: $@" unless $data;
            die "Invalid data in $fname: $data" unless ref $data;
            $self = $data;
            $_self->{format} = 'dumper' if $_self->{format} eq 'auto';
        } elsif ($str =~ /^{/) {
            $self = JSON->new->decode($str);
            $_self->{format} = 'json' if $_self->{format} eq 'auto';
        }
        else {
            $self = thaw($str);
            $_self->{format} = 'storable' if $_self->{format} eq 'auto';
        }
    } else {
        $_self->{format} = 'json' if $_self->{format} eq 'auto'; # default format for new files
        $self = {};
    }

    bless $self => $class;
    $meta->{$self} = $_self;
    return $self;
}

sub commit {
    my $self = shift;
    my $_self = $meta->{$self};

    if ($_self->{removed}) {
        croak "$_self->{fname} is already removed and can't be commited";
    }
    if ($_self->{read_only}) {
        croak "Can't commit to $_self->{fname}, object is read only";
    }

    my $fname = $_self->{fname};
    my $tmp_fname = "$fname.tmp";
    open my $tmp, '>', $tmp_fname;

    my $serialized;
    if ($_self->{format} eq 'dumper') {
        my $dumper = Data::Dumper->new([ { %$self } ], [ qw(data) ]);
        $dumper->Terse(0); # somebody could enable terse mode globally; TODO - explicitly specify other options too?
        $dumper->Purity(1);
        $dumper->Sortkeys(1);
        $serialized = $dumper->Dump;
    }
    elsif ($_self->{format} eq 'json') {
        $serialized = JSON->new->encode({ %$self });
    }
    else {
        $serialized = nfreeze({ %$self });
    }
    print {$tmp} $serialized or die "print failed: $!";

    chmod $_self->{mode}, $tmp_fname if defined $_self->{mode};
    rename $tmp_fname => $fname;
}

sub DESTROY {
    local $@;
    my $self = shift;

    my $_self = $meta->{$self};
    if ($_self->{auto_commit} and not $self->{removed}) {
        my $commited = eval {
            $self->commit();
            1;
        };
        delete $meta->{$self}; # delete object anyway, commited or not
        unless ($commited) {
            ERROR $@;
        }
    }
    else {
        delete $meta->{$self};
    }
}

sub remove {
    my $self = shift;

    my $_self = $meta->{$self};
    if ($_self->{read_only}) {
        croak "Can't remove $_self->{fname}, object is read only";
    }
    if (-e $_self->{fname}) {
        unlink $_self->{fname} or die "Can't remove $_self->{fname}: $!";
    }
    if ($_self->{lock}) {
        my $lock_fname = $_self->{lock}->name;
        if (-e $lock_fname) {
            unlink $lock_fname or die "Can't remove $lock_fname: $!";
        }
    }
    $_self->{removed} = 1;
    delete $self->{$_} for keys %$self;
}

1;

__END__