File Coverage

blib/lib/Zoidberg/DispatchTable.pm

Criterion	Covered	Total	%
statement	124	158	78.4
branch	45	66	68.1
condition	4	8	50.0
subroutine	15	20	75.0
pod	6	8	75.0
total	194	260	74.6

package Zoidberg::DispatchTable;

our $VERSION = '0.981';

use strict;
use Zoidberg::Utils qw/debug bug error/;
use Exporter::Tidy all => [qw/stack wipe tag tags/];

our $ERROR_CALLER = 1;

# reserved keys _AUTOLOAD and _META

# $self->[0] hash with arrays of dispatch strings/refs
# $self->[1] hash with arrays of tags
# $self->[2] object ref
# $self->[3] object can parent bit
# $self->[4] array with keys to keep them in order
# $self->[5] iteration index for keys()

# keys are kept in order to avoid inconsistencies
# for example when iterating trough {parser}

sub new { # create a blessed AND tie'ed hash
	my $class = shift;
	my %hash;
	tie %hash, $class, @_;
	bless \%hash, $class;
}

sub TIEHASH  {
	my $class = shift;
	my $ref = shift || error 'need object ref to tie hash';
	# $ref is either array ref or object ref
	my $self = (ref($ref) eq 'ARRAY')
		? $ref
		: [{}, {}, $ref, $ref->can('parent'), [], 0];
	bless $self, $class;
	while (my $hash = shift @_) {
		$self->STORE($_, $$hash{$_}) for keys %$hash;
	}
	return $self;
}

sub STORE {
	my ($self, $key, $value) = @_;
	my $tag = 'undef';
	($value, $tag) = @$value if ref($value) eq 'ARRAY';

	my $t = ref $value;
	if ($t eq 'HASH') {
		unless (tied $value) { # recurs tie'ing
			tie %$value, __PACKAGE__, $$self[2], $value;
			# be careful to reuse same ref - else perl bugs :(
		}
		# else just store the tied hash
	}
	elsif (! $t) {
		$value =~ s/(^\s*|\s*$)//g;
		error "Can't use ==>$value<== as subroutine."
			if ! length $value
			or $value =~ /^\$/; # no vars
	}
	elsif ($t ne 'CODE') { bug "Can't store ref of type $t in DispatchTable" }

	push @{$self->[0]{$key}}, $value;
	push @{$self->[1]{$key}}, $tag;
	push @{$self->[4]}, $key;
}

sub add {
	my $self = tied %{ shift() };
	$self->STORE(@_);
}

sub FETCH {
	my ($self, $key) = @_;
	if ( exists $$self[0]{$key} and scalar @{$$self[0]{$key}} ) {
		$$self[0]{$key}[-1] = $self->convert($self->[0]{$key}[-1])
			unless ref $self->[0]{$key}[-1];
		return $self->[0]{$key}[-1];
	}
	elsif ($self->EXISTS('_AUTOLOAD')) {
		my $sub;
		for (@{$self->[0]{_AUTOLOAD}}) {
	        	$sub = $_->($key);
        		next unless $sub;
		        $self->STORE($key, $sub) unless $self->EXISTS($key);
        		return $self->FETCH($key);
		}
	}
	return undef;
}

sub convert {
	my ($self, $ding) = @_;

	if ($ding =~ /^\s*sub\s*{.*}\s*$/) { # undocumented hack
		debug "going to eval: $ding";
		my $closure = eval $ding;
		die if $@;
		return sub { $closure->($$self[2], @_) };
	}

        $ding =~ s#^->((\w+)->)?#
		( $self->[3] ? q/parent->/         : '' ) .
		( $1         ? qq/{objects}{$2}->/ : '' )
	#e;

	if ($ding =~ /\(\s*\)$/s) { $ding =~ s/\s*\)$/\@_\)/ }
        elsif ($ding =~ /\(.*\)$/s) { $ding =~ s/\)$/, \@_\)/ }
	else { $ding .= '(@_)' }

	debug "going to eval: sub { \$self->[2]->$ding }";
	my $sub = eval "sub { \$\$self[2]->$ding }";
	die if $@;
	return $sub;
}

sub EXISTS { exists $_[0][0]->{$_[1]} and scalar @{$_[0][0]->{$_[1]}} }

sub DELETE { # doesn't really delete, merely pops
	my ($self, $key) = @_;
	return undef unless exists $self->[0]{$key};

	pop @{$self->[1]{$key}};
	my $re = pop @{$self->[0]{$key}};

	unless (scalar @{$self->[0]{$key}}) {
		delete $self->[0]{$key};
		delete $self->[1]{$key};
		@{$self->[4]} = grep {$_ ne $key} @{$self->[4]};
	}

	return $re;
}

sub pop {
	my $self = tied %{ shift() };
	$self->DELETE(@_);
}

sub CLEAR    {
	%{$_[0][0]} = ();
	%{$_[0][1]} = ();
	@{$_[0][4]} = ();
	  $_[0][5]  =  0;
}

sub FIRSTKEY {
	$_[0][5] = 0;
	goto \&NEXTKEY
}

sub NEXTKEY  {
	my $self = shift;
	if ($$self[5] > $#{$$self[4]}) {
		$$self[5] = 0;
		return wantarray ? () : undef;
	}
	elsif (wantarray) { # ($key, $value) = each(%table)
		my $key = $$self[4][$$self[5]++];
		return $key, $self->FETCH($key);
	}
	else { return $self->[4][$$self[5]++] } # for $key (keys %table)
}

sub stack {
	my $self = tied %{ shift() };
	my ($key, $use_tag) = @_;
	return () unless exists $$self[0]{$key};
	for (@{$self->[0]{$key}}) { $_ = $self->convert($_) unless ref $_ }
	return map [ $$self[0]{$key}[$_], $$self[1]{$key}[$_] ], (0..$#{$$self[0]{$key}})
		if $use_tag;
	return @{$self->[0]{$key}};
}

sub tag {
	my $self = tied %{ shift() };
	my $key = shift;
	return undef unless exists $$self[1]{$key};
	return $$self[1]{$key}[-1];
}

sub tags {
	my $self = tied %{ shift() };
	my $key = shift;
	return undef unless exists $$self[1]{$key};
	return @{$self->[1]{$key}};
}

sub wipe {
	my $self = tied %{ shift() };
	my ($tag, @keys) = @_;
	@keys = keys %{$self->[0]} unless scalar @keys;
	my %old;
	for my $key (@keys) {
		for (my $i = 0; $i < @{$self->[1]{$key}}; $i++) {
			next unless $self->[1]{$key}[$i] eq $tag;
			$old{$key} = [$self->[0]{$key}[$i], $tag];
			$self->[0]{$key}[$i] = undef;
			$self->[1]{$key}[$i] = undef;
		}
		@{$self->[0]{$key}} = grep {defined $_} @{$self->[0]{$key}};
		@{$self->[1]{$key}} = grep {defined $_} @{$self->[1]{$key}};
		unless (scalar @{$self->[0]{$key}}) {
			delete $self->[0]{$key};
			delete $self->[1]{$key};
			@{$self->[4]} = grep {$_ ne $key} @{$self->[4]};
		}
	}
	return \%old;
}

1;

__END__