File Coverage

blib/lib/Tie/Hash/CustomStorage.pm

Criterion	Covered	Total	%
statement	86	107	80.3
branch	29	48	60.4
condition	4	6	66.6
subroutine	18	26	69.2
pod	0	3	0.0
total	137	190	72.1

package Tie::Hash::CustomStorage ;

use warnings ;
use Carp;
use strict;

use vars qw($VERSION) ;
$VERSION = sprintf "%d.%03d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/;

use base qw/Tie::Hash/;

# if not init or tie_hash or init parameter is given, behaves exactly
# as a standard hash

sub TIEHASH
  {
    my $type = shift ;
    my %args = @_ ;

    my %data = () ;
    my $autovivify = 1 ;

    my $self =  { data => \%data }  ;

    #print "Creating Tie::Hash with '",join("','", %args),"'\n";

    my $load = sub
      {
	my $file = $_[0].'.pm';
	$file =~ s!::!/!g;
	require $file unless defined *{$_[0].'::'} ;
      };

    if (defined $args{autovivify})
      {
	$autovivify = delete $args{autovivify} ;
      }

    # applied to hash containing the storage
    if (defined $args{tie_hash})
      {
	my $p = delete $args{tie_hash} ;
	my ($class, @args) = ref $p ? @$p : ($p) ;
	$load->($class) ;
	$self->{tie_hash_obj} = tie %data, $class, @args ;
      }

    my $init_obj = delete $args{init_object} ;

    # applied to storage
    if (defined $args{class_storage})
      {
	my $p = delete $args{class_storage} ;
	my ($class, @args) = ref $p ? @$p : ($p) ;
	$load->($class) ;

	$self->{init} = $autovivify ?
	  sub
	    {
	      my $idx = shift ;
	      my $obj = shift || $class -> new (@args) ;
	      $init_obj->($obj,$idx) if defined $init_obj ;

	      $self->{data}{$idx} = $obj ;
	    } : sub {} ;

	$self->{class_storage} = $class ;
      }
    elsif (defined $args{tie_storage})
      {
	my $p = delete $args{tie_storage} ;
	my ($class, @args) = ref $p ? @$p : ($p) ;
	$load->($class) ;
	$self->{init} = sub
	  {
	    #print "storage init with tie_storage\n";
	    my $ref = $self->get_storage_ref($_[0]) ;
	    my $obj = tie $$ref, $class, @args ;
	    $init_obj->($obj,$_[0]) if defined $init_obj ;
	  } ;
      }
    elsif (defined $args{init_storage})
      {
	my ($init_method, @args) = @{delete $args{init_storage}} ;
	$self->{init} = sub
	  {
	    #print "storage init with init\n";
	    my $ref = $self->get_storage_ref($_[0]) ;
	    $init_method->($ref, @args)
	  } ;
      }
    else
      {
	$self->{init} = sub {} ;
      }

    croak __PACKAGE__,": Unexpected TIEHASH argument: ",
      join(' ',keys %args) if %args ;

    bless $self, $type  ;
  }

# this one is tricky, all direct method calls to this class must be
# forwarded to the tied object hidden behind the %data hash
sub AUTOLOAD
  {
    our $AUTOLOAD ;
    my $self=shift ;
    my $obj = $self->{tie_hash_obj} ;

    if (defined $obj)
      {
	my ($pack,$method) = ($AUTOLOAD =~ /(.*)::(\w+)/) ;
	$obj->$method(@_) ;
      }
    else
      {
	croak "Undefined subroutine $AUTOLOAD called";
      }
  }

sub FETCH
  {
    my ($self,$idx) = @_ ;

    #print "TieHash: fetch idx $idx\n";
    $self->{init}->($idx) unless defined $self->{data}{$idx} ;

    return $self->{data}{$idx} ;
  }

# Implementation note: The tie must be applied to the variable which
# is actually stored. For a standard hash this variable is
# $self->{$name}{$key}. For a tied hash, the actual variable is hidden
# within the tied hash. The code will find the actual location if the
# tied hash inherits from StdHash or if the tied hash follows the
# example of the camel book (e.g. $self->{DATA} or $self->{data}). If
# all fails, the user's tied hash must provide a get_data_ref method
# that give a ref to the actual location of the variable to be tied.

sub get_storage_ref
  {
    my ($self,$idx) = @_ ;
    my $h_obj = $self->get_user_tied_hash_object ;

    return \$self->{data}{$idx} unless defined $h_obj;

    # print "get_scalar_ref called for $h_obj,$idx\n";
    return $h_obj->isa('Tie::StdHash') ? \$h_obj->{$idx} :
      defined $h_obj->{DATA} ? \$h_obj->{DATA}{$idx} :
	defined $h_obj->{data} ? \$h_obj->{data}{$idx} :
	  $h_obj->can('get_data_ref') ? $h_obj->get_data_ref($idx):
	    die ref($h_obj)," must provide a get_data_ref method" ;
  }

sub get_user_tied_hash_object
  {
    my $self = shift ;
    return  tied %{$self->{data}} ;
  }

sub get_tied_storage_object
  {
    my ($self,$idx) = @_ ;
    $self->{init}->($idx) unless defined $self->{data}{$idx} ;
    #print "TieHash: get_storage on idx $idx\n";
    my $r = $self->get_storage_ref($idx) ;
    tied ($$r) ;
  }

sub STORE
  {
    my ($self,$idx, $data) = @_ ;

    #print "TieHash: store idx $idx, data ", defined $data ? $data : 'UNDEF', " (", join('~',keys %{$self->{data}}),")\n";

    my @args;
    if (defined $self->{class_storage} and defined $data)
      {
	if (ref($data) eq $self->{class_storage})
	  {
	    # provided object will be run through init process
	    $self->{init}->($idx,$data) ;
	    return $self->{data}{$idx} ;
	  }
	else
	  {
	    croak ref($self),": wrong object assigned to index '$idx'. ",
	      "Expected '$self->{class_storage}', got '",ref($data),"'" ;
	  }
      }

    $self->{init}->($idx,$data) unless defined $self->{data}{$idx} ;

    return $self->{data}{$idx} = $data ;
  }

sub FIRSTKEY { my $a = scalar keys %{$_[0]->{data}}; each %{$_[0]->{data}} }
sub NEXTKEY  { each %{$_[0]->{data}} }


sub STORESIZE
  {
    my ($self,$size) = @_ ;

    for (my $i = $#{$_[0]->{data}}; $i<$size; $i++)
      {
	$self->{init}->($i);
      }
  }

sub EXISTS    { exists $_[0]->{data}{$_[1]} }
sub DELETE    { delete $_[0]->{data}{$_[1]} }
sub CLEAR    { %{$_[0]->{data}} = () }
sub SCALAR   { scalar %{$_[0]->{data}} }

sub DESTROY {}

1;

__END__