view release on metacpan or  search on metacpan

lib/Tie/SaveLater.pm  view on Meta::CPAN

#
# $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__

# Below is stub documentation for your module. You'd better edit it!

=head1 NAME

Tie::SaveLater - A base class for tie modules that "save later".

=head1 SYNOPSIS

  package Tie::Storable;
  use base 'Tie::SaveLater';
  use Storable qw(retrieve nstore);
  __PACKAGE__->make_subclasses;
  sub load{ retrieve($_[1]) };
  sub save{ nstore($_[0], $_[0]->filename) };
  1;

  # later
  use Tie::Storable;
  {
      tie my $scalar => 'Tie::Storable', 'scalar.po';
      $scalar = 42;
  } # scalar is automatically saved as 'scalar.po'.
  {
      tie my @array => 'Tie::Storable', 'array.po';
      @array = qw(Sun Mon Tue Wed Fri Sat);
  } # array is automatically saved as 'array.po'.