File Coverage

blib/lib/Tie/SaveLater.pm

Criterion	Covered	Total	%
statement	57	61	93.4
branch	13	20	65.0
condition	2	3	66.6
subroutine	16	18	88.8
pod	3	7	42.8
total	91	109	83.4

#
# $Id: SaveLater.pm,v 0.05 2020/08/05 18:26:03 dankogai Exp dankogai $
#
package Tie::SaveLater;
use strict;
use warnings;
our $VERSION = sprintf "%d.%02d", q$Revision: 0.05 $ =~ /(\d+)/g;
use Carp;
our $DEBUG = 0;
my (%OBJ2FN, %FN2OBJ, %OPTIONS);

sub make_subclasses{
    my $pkg = shift;
    for my $type (qw/SCALAR ARRAY HASH/){
	my $class = $pkg; my $Type = ucfirst(lc $type);
	eval qq{ package $class\:\:$type;
		 require Tie\:\:$Type;
	     push our \@ISA, qw($class Tie\:\:Std$Type); };
	$@ and croak $@;
    }
}

sub load { my $class = shift; croak "$class, please implement load()!" }
sub save { my $class  = ref shift; croak "$class, please implement save()!" }

sub options{
    my $self = shift;
    @_ and $OPTIONS{0+$self} = [ @_ ];
    return $OPTIONS{0+$self} ? @{ $OPTIONS{0+$self} } : ();
}

sub super_super{
    my $self = shift;
    my $name = shift;
    no strict 'refs';
    &{ ${ref($self) . "::ISA"}[1] . "::$name"}($self, @_);
}

sub TIEHASH  { return shift->TIE('HASH'   => @_) };
sub TIEARRAY { return shift->TIE('ARRAY'  => @_) };
sub TIESCALAR{ return shift->TIE('SCALAR' => @_) };

my %types2check = map { $_ => 1 } qw/HASH ARRAY/;
sub TIE{
    my $class = shift;
    my $type = shift;
    my $filename = shift or croak "filename missing";
    my $self;
    if (-f $filename){
	$self = $class->load($filename) or croak "$filename : $!";
	croak "existing $filename does not store $type"
	    if $types2check{$type} and !$self->isa($type);
    }else{
	$self =
	    { HASH => {}, ARRAY => [], SCALAR => \do{ my $scalar }}->{$type};
    }
    bless $self => $class.'::'.$type;
    $DEBUG and carp sprintf("tied $filename => 0x%x", 0+$self);
    @_ and $self->options(@_);
    $self->_regobj($filename);
    $self;
}

sub UNTIE{
    my $self = shift;
    $self->save;
    $DEBUG and carp "untied ", $self->filename;
    $self->_unregobj();
}

sub DESTROY{ shift->UNTIE }

sub filename{ $OBJ2FN{ 0+shift } }

sub _regobj{
    $OBJ2FN{0+$_[0]} = $_[1];
    $FN2OBJ{$_[1]} = 0+$_[0];
    return;
}

sub _unregobj{
    delete $FN2OBJ{ $OBJ2FN{ 0+$_[0] } };
    delete $OPTIONS{ 0+$_[0] };
    delete $OBJ2FN{ 0+$_[0] };
    return;
}

1;

__END__