File Coverage

blib/lib/Tie/Alias.pm

Criterion	Covered	Total	%
statement	36	83	43.3
branch	9	22	40.9
condition	0	5	0.0
subroutine	11	30	36.6
pod	0	1	0.0
total	56	141	39.7

package Tie::Alias;

use 5.008;

use Carp ();
our $VERSION = '1.01';


sub TIESCALAR {

	my ( $class , $ref ) = @_ ;
	ref($ref) or $ref = \$_[1];
	if ( tied($$ref) ) {
		# we are re-tieing something
		return tied ($$ref);
	}else{
		# $ref is already a pointer to the object
		bless $ref, $class;
	};
};

sub STORE {
	${$_[0]} = $_[1];
};


sub FETCH {
	${$_[0]};
};

sub TIEARRAY {
	goto &Tie::Alias::Array::TIEARRAY;
};

sub TIEHASH {
	goto &Tie::Alias::Hash::TIEHASH;
};


sub import {
	@_ == 1 and return;
	shift;
	goto &alias;
};
sub alias(@) {
	@_ % 2 and Carp::croak "Uneven alias => original pairings in use Tie::Alias";

	while(@_){
		my $r = ref($_[0]);
	   	if (!$r){
			tie $_[0], __PACKAGE__, \$_[1];
		}elsif( $r eq 'ARRAY' ){
			tie @{$_[0]}, __PACKAGE__, $_[1];

		}elsif( $r eq 'HASH' ){
			tie %{$_[0]}, __PACKAGE__, $_[1];
		}else{
			# Carp::carp "Object references already have aliasing semantics";
			tie $_[0], __PACKAGE__, \$_[1];


		};


		shift; shift;
	};

};



package Tie::Alias::Array;


sub TIEARRAY {

        my ( $class , $ref ) = @_ ;
	my $rval = eval {
          if ( tied(@$ref)  ) {
                # we are re-aliasing something
                return tied ($$ref);
          }else{
                # $ref is already a pointer to the object
                return bless $ref, __PACKAGE__;
          };
	};
        $@ and Carp::croak "$ref IS NOT AN ARRAY REFERENCE";
	return $rval;
};

sub FETCH{
	$_[0]->[$_[1]];
};
sub STORE{
	$_[0]->[$_[1]] = $_[2];
};
sub FETCHSIZE{
	scalar @{$_[0]};
};
sub STORESIZE{
	$#{$_[0]} = $_[1] -1 ;
};
sub POP{
	pop @{$_[0]};
};
sub CLEAR{
	@{$_[0]} = ();
};
sub PUSH{
	my $r = shift;
	push @{$r}, @_;
};
sub SHIFT{
	shift @{$_[0]};
};
sub UNSHIFT{
	my $r = shift;
	unshift @{$r}, @_;
};
sub SPLICE{
	my $r = shift;
	my $o = shift || 0;
	my $l = shift || scalar(@{$r}) - $o;
	splice @{$r}, $o, $l, @_;
};
sub DELETE{
	delete $_[0]->[$_[1]];
};
sub EXISTS{
	exists $_[0]->[$_[1]];
};

package Tie::Alias::Hash;


sub TIEHASH {
        my ( $class , $ref ) = @_ ;
	my $rval = eval {
          if ( tied(%$ref)  ) {
                # we are re-aliasing something
                return tied (%$ref);
          }else{
                # $ref is already a pointer to the object
                return bless $ref, __PACKAGE__;
          };
	};
        $@ and Carp::croak "$ref IS NOT A HASH REFERENCE";
	return $rval;
};


sub FETCH{
	$_[0]->{$_[1]};
};
sub STORE{
	$_[0]->{$_[1]} = $_[2];
};
sub EXISTS{
	exists $_[0]->{$_[1]};
};
sub DELETE{
	delete $_[0]->{$_[1]};
};
sub CLEAR{
	%{$_[0]} = ();
};
sub FIRSTKEY{
	keys %{$_[0]};
	each %{$_[0]};
};
sub NEXTKEY{
	each %{$_[0]};
};

1;
__END__