File Coverage

blib/lib/Tie/Array/CustomStorage.pm

Criterion	Covered	Total	%
statement	82	105	78.1
branch	29	52	55.7
condition	4	6	66.6
subroutine	17	23	73.9
pod	0	3	0.0
total	132	189	69.8

package Tie::Array::CustomStorage ;

use warnings ;
use Carp;
use strict;

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

use base qw/Tie::Array/;

# if not init or tie_array or init parameter is given, behaves exactly
# as a standard array

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

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

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

    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 array containing the storage
    if (defined $args{tie_array})
      {
	my $p = delete $args{tie_array} ;
	my ($class, @args) = ref $p ? @$p : ($p) ;
	$load->($class) ;
	$self->{tie_array_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 TIEARRAY 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 array
sub AUTOLOAD
  {
    our $AUTOLOAD ;
    my $self=shift ;
    my $obj = $self->{tie_array_obj} ;

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

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

    #print "TieArray: 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 array this variable is
# $self->{$name}[$key]. For a tied array, the actual variable is hidden
# within the tied array. The code will find the actual location if the
# tied array inherits from StdArray or if the tied array follows the
# example of the camel book (e.g. $self->{DATA} or $self->{data}). If
# all fails, the user's tied array 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_array_object ;

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

    # print "get_scalar_ref called for $h_obj,$idx\n";
    return $h_obj->isa('Tie::StdArray') ? \$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_array_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 "TieArray: get_storage on idx $idx\n";
    my $r = $self->get_storage_ref($idx) ;
    tied ($$r) ;
  }

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

    #print "TieArray: store idx $idx, data ", defined $data ? $data : 'UNDEF', " (", join('~', @{$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 STORESIZE
  {
    my ($self,$size) = @_ ;

    my $old = scalar @{$self->{data}} ;

    return if $old == $size ;

    if ($size < $old) {
      #print "Reducing array from $old to $size elements\n";
      $#{$self->{data}} = $size -1 ;
      return ;
    }

    #print "Growing array from $old to $size elements\n";

    for (my $i = $old; $i<$size; $i++) {
      $self->{init}->($i);
    }

  }

sub FETCHSIZE { scalar @{$_[0]->{data}} }


sub EXISTS    { exists $_[0]->{data}[$_[1]] ;}
sub DELETE    { delete $_[0]->{data}[$_[1]] ;}

sub DESTROY {}

1;

__END__