package Persistent; # -*- perl -*-

=head1 Description

Creates persistent multi-dimensional hashes or arrays (references, really).
To use, simply create a hash ref or an array ref using:

$hashref = newhash Persistent '/path/to/file';
$arrayref = newarray Persistent 'path/to/anotherfile';

This will create a reference to a hash or an array. If the file exists,
it should contain the previous contents of the variable (written because
of a previous run), and it is read in.  The only thing is that
ref($hashref) will be "Persistent" instead of "HASH", but please do
treat it like any ordinary hashref. Same goes for the arrayref.

When a ref is destroyed, it is automatically stored in the file,
so it can be revived in a later program run.

This doesn't work when somewhere in the array there is a reference to
an object, it can only consist of scalar values or arrays of scalar
variables, or arrays or arrays of... etc.

=head1 Comments

About the code:

Yes, I know what it says in the manpage about hashing on references.
However, in this case, it does exactly what I want.

The code now uses Storable, but loading of "old" files still works
transparently...

Will now only save when the destructor is invoked with the same pid
as the constructor, to prevent duplicate saves on fork.

A note about efficiency: a very neat way is to write out the contents of
a complex structure in a way the perl parser is able to read it. Reading
it back in is easily accomplished by using "require", then. However, I
tried that method, and it seems it uses twice as much memory as the 
method I'm using now. (Contrary to what I expected). Since I am really
trying to limit memory usage, I dumped that idea.

The data here is written with a format that somewhat resembles but, isn't
fully compatible with, FreezeThaw.pm. This uses (length, data) to store
the data. I used to use an escape character, but that didn't process too
fast, and the regexps for parsing it seemed buggy.

=cut

use Carp;
use Storable;
use Cwd;

# Doesn't use the exporter module, but lets put the version here anyway.
# 
use vars qw($VERSION);
$VERSION = '0.602'; # in par with Storable version number now

my(%data);
my($buf);

my $storable_magic1 = "perl-store";
my $storable_magic2 = "pst0";

sub _abspath ($);
sub _select ($$);
sub _revivehash ($);
sub _revivearray ($);
sub _revivescalar ($);
sub _reviveNE ($);

sub newhash {
    my($type, $file) = @_;
    my($self);
    local(*FILE);

    $file = _abspath($file);
    if ( -r $file ) {
	eval {
	    $self = _select(\&_revivehash, $file);
	};
	if ( $@ ) {
	    carp $@;
	    undef $self;
	}
	if ( !defined($self) ) {
	    carp "could not parse $file";
	    $self = {};
	}
    }
    else {
	$self = {};
    }
    bless $self, $type;
    $data{$self} = [$file, $$];
    $self;
}

sub newarray {
    my($type, $file) = @_;
    my($self);
    local(*FILE);

    $file = _abspath($file);
    if ( -r $file ) {
	eval {
	    $self = _select(\&_revivearray, $file);
	};
	if ( $@ ) {
	    carp $@;
	    undef $self;
	}
	if ( !defined($self) ) {
	    carp "could not parse $file";
	    $self = [];
	}
    }
    else {
	$self = [];
    }
    bless $self, $type;
    $data{$self} = [$file, $$];
    $self;
}

sub DESTROY {
    my($self) = shift;
    my($file, $pid);
    local(*FILE);

    ($file, $pid) = @{$data{$self}};
    return unless $pid eq $$;

#    if ( -r $file ) {
#    	rename $file, "$file.bak";
#    }
    store $self, $file;
    delete $data{$self};
}

sub _abspath ($) {
    my $file = shift;

    if ( $file !~ m-^/- ) {
	$file = cwd() . "/$file";
    }
    $file;
}

sub _select ($$) {
    my($code, $file) = @_;
    my($ret);

    open(FILE, $file) or croak "cannot open $file: $!\n";
    $buf = "";
    read(FILE, $buf, 16);
    if ( substr($buf, 0, length $storable_magic1) eq $storable_magic1 ||
	 substr($buf, 0, length $storable_magic2) eq $storable_magic2 )
    {
	close(FILE);
	$ret = retrieve $file;
	# Storable-oddity workaround... fix scalar to object...
	if ( ref($ret) && $ret =~ /SCALAR/ && ref($$ret) ) {
	    warn "Storable bug workaround\n";
	    my $type = ref($ret);
	    my $foo = $$ret;
	    $ret = $foo;
	    bless $ret, $type;
	}
    }
    else {
	$ret = $code->(*FILE);
	close(FILE);
    }
    $ret;
}

sub _revivescalar ($) {
    local(*FILE) = $_[0];
    local($len, $self);

    return undef unless substr($buf, 0, 1) eq "\$";
    $buf = substr($buf, 1);
    if ( substr($buf, 0, 1) eq "_" ) {
	$buf = substr($buf, 1);
	read(FILE, $buf, 16 - length($buf), length($buf));
	return undef; # legit undef value
    }
    return undef unless ( $buf =~ /^(\d+)\|([\w\W]*)/ );
    $len = $1;
    $buf = $2;
    if ( $len <= length($buf) ) {
	$self = substr($buf, 0, $len);
	$buf = substr($buf, $len);
    }
    else {
	$self = $buf;
	$buf = "";
	read(FILE, $self, $len - length($self), length($self));
    }
    read(FILE, $buf, 16 - length($buf), length($buf));
    $self;
}
    
sub _reviveNE ($) {
    local(*FILE) = $_[0];
    my($c);

    $c = substr($buf, 0, 1);
    if ( $c eq "\$" ) {
	return _revivescalar(*FILE);
    }
    elsif ( $c eq "%" ) {
	return _revivehash(*FILE);
    }
    elsif ( $c eq "\@" ) {
	return _revivearray(*FILE);
    }
    else {
	return undef;
    }
}

sub _revivehash ($) {
    local(*FILE) = $_[0];
    my(%self, $key);

    read(FILE, $buf, 16 - length($buf), length($buf));
    return undef unless substr($buf, 0, 1) eq "%";
    $buf = substr($buf, 1);
    # parens balance {
    while ( substr($buf, 0, 1) ne "}" ) {
	$key = _revivescalar(*FILE);
	return undef if ( !defined($key) );
	$self{$key} = _reviveNE(*FILE);
    }
    $buf = substr($buf, 1);
    read(FILE, $buf, 16 - length($buf), length($buf));
    \%self;
}

sub _revivearray ($) {
    local(*FILE) = $_[0];
    my(@self, $val, $i, $len);

    read(FILE, $buf, 16 - length($buf), length($buf));
    return undef unless substr($buf, 0, 1) eq "\@";
    $buf = substr($buf, 1);
    return undef unless ( $buf =~ /^(\d+)\|([\w\W]*)/ );
    $len = $1;
    $buf = $2;
    read(FILE, $buf, 16 - length($buf), length($buf));
    if ( $len ) {
	$self[$len-1] = undef; # pre-allocate
	for($i = 0; $i < $len; $i++) {
	    $self[$i] = _reviveNE(*FILE);
	}
    }
    \@self;
}

1;