File Coverage

blib/lib/Symbol/Table.pm

Criterion	Covered	Total	%
statement	307	324	94.7
branch	16	26	61.5
condition			n/a
subroutine	88	93	94.6
pod	0	7	0.0
total	411	450	91.3

package Symbol::Table;

use 5.008;

use strict;
use warnings;
use Data::Dumper;
use Carp;

our $VERSION = '1.01';

#########################################################################
sub _callers_package_name
#########################################################################
{
	# @_ contains 0 or 1 item
	# item is a string containing the name of the package
	# whose symbol table we want to create.
	# note: package name looks like a regular perl package name,
	#       it does NOT look like a perl symbol table name
	#	i.e. use 'main::mypackage', dont use 'main::mypackage::'
	# if item is missing, use package name of caller.

	my $pkg_name;
	if(scalar(@_)==1)
		{
		# if caller passes in a package
		$pkg_name=shift(@_) ;
		}
	else
		{
		# by default, create a symbol table for callers package
		$pkg_name='main::'. ((caller(1))[0]);
		}

	unless($pkg_name=~m{^[\w:]+$})
		{
		croak "bad package name '$pkg_name'";
		}

	return $pkg_name;
}


my %warehouse;

# no GLOB and no NAME
my @element_types_array = qw(SCALAR ARRAY HASH CODE );
sub ElementTypes
{
	return (@element_types_array);
}

my @hierarchy_types_array = qw(PACKAGE);
sub HierarchyTypes
{
	return (@hierarchy_types_array);
}

sub AllTypes
{
	return (@element_types_array, @hierarchy_types_array);
}


my %valid_type_hash;
map{$valid_type_hash{$_}=1;} AllTypes;

#########################################################################
# Create a tied hash that access things of a particular type in symbol table
# (type is scalar, array, hash, code, glob, filehandle, name, package)
#########################################################################
sub New
{
	my $class=shift(@_);

	my $type = 'PACKAGE';
	$type = shift(@_) if (scalar(@_));

	unless(exists($valid_type_hash{$type}))
		{
		print "I can handle the following types "
			.join(" ", AllTypes)."\n";
		croak "Error: bad type '$type'";
		}


	my $pkg_name = _callers_package_name(@_);

	my %hash;
	tie %hash, 'Symbol::Table::Tie', $pkg_name.'::', $type;

	my $ref = \%hash;

	bless $ref, $class;

	$warehouse{$ref}=
		{
		PackageName => $pkg_name,
		Type	=> $type,
		};

	return $ref;

}


sub Package
{
	return $warehouse{$_[0]}->{PackageName};
}

sub Type
{
	return $warehouse{$_[0]}->{Type};
}

sub InvoiceWarehouse
{
	print Dumper \%warehouse;
}

sub DESTROY
{
	my $obj=$_[0];
	delete($warehouse{$_[0]});
}

#########################################################################
#########################################################################
package Symbol::Table::Tie;
#########################################################################
#########################################################################
use Data::Dumper;
use Carp;

sub SYMBOL_TABLE_NAME    {0;}	# main::mypackage::subpackage::
sub SYMBOL_TABLE_TYPE    {1;}	# CODE or ARRAY etc


sub debugging
{
	return unless($::DEBUG);

	my ($pkg, $filename, $linenum) = caller(0);

	my $suffix = " at $filename line $linenum\n";

	my $msg = shift(@_);

	$msg .= $suffix;

	warn $msg;
}


sub TIEHASH
{
	debugging( "TIEHASH" );
	debugging Dumper \@_;

	my ($class, $st_name, $type)=@_;

	my $st_package = $st_name;
	$st_package =~ s{::$}{};

	my $obj=[];
	$obj->[SYMBOL_TABLE_NAME]=$st_name;
	$obj->[SYMBOL_TABLE_TYPE]=$type;

	return bless $obj, $class;
}



sub DESTROY
{
	debugging "DESTROY";
	my ($obj)=@_;

}

sub FETCH
{
	no strict; no warnings;

	my ($obj, $key)=@_;
	debugging "FETCH: looking for key '$key' in ". $obj;

	if($obj->[SYMBOL_TABLE_TYPE] eq 'PACKAGE')
		{
		my $new_package_name = $obj->[SYMBOL_TABLE_NAME] . $key;
		debugging "new_package_name is $new_package_name";
		my $new_obj =
			Symbol::Table->New('PACKAGE', $new_package_name );
		return $new_obj;
		}
	else
		{
		local *local_val;
		my $eval=
			  '*local_val = $'
			. $obj->[SYMBOL_TABLE_NAME]
			. "{$key};";

		debugging "eval is >>>$eval<<<\n";
		eval($eval);

		my $st_type = $obj->[SYMBOL_TABLE_TYPE];

		my $ret = *local_val{$st_type};
		return $ret;
		}


}

sub STORE
{
	debugging "STORE";
	my ($obj, $key, $value)=@_;

	my $st_type = $obj->[SYMBOL_TABLE_TYPE];

	my $val_type = ref($value);
	croak "Must store a reference, not value '$value'"
		unless($val_type);

	croak "Type mismatch, $st_type ne $val_type"
		if ($st_type ne $val_type);

	my $eval='*' . $obj->[SYMBOL_TABLE_NAME] . $key."=\$value;";

	debugging "eval is >>>$eval<<<\n";
	eval($eval);


}

sub FIRSTKEY
{
	debugging "FIRSTKEY";
	my ($obj)=@_;

	my $eval='@keys = keys( %'.$obj->[SYMBOL_TABLE_TYPE].');';
	debugging "eval is >>>$eval<<<";
	eval($eval);

	return $obj->NEXTKEY(); #prevkey doesnt matter

}


my %pass_condition_for_type =
	(
	SCALAR => '$boolean=1 if(defined($sym));' ,
	ARRAY  => '$boolean=1 if(defined(@sym));' ,
	HASH   => '$boolean=1 if(defined(%sym));' ,
	CODE   => '$boolean=1 if(defined(&sym));' ,
	PACKAGE=> '$boolean=1 if($key=~m{::$});' ,
	);

sub NEXTKEY
{
	debugging "NEXTKEY";
	my ($obj, $prevkey)=@_; # prev key is ignored

	my $st_type = $obj->[SYMBOL_TABLE_TYPE];
	my $st_name = $obj->[SYMBOL_TABLE_NAME];

	die "Error: no pass condition defined for type '$st_type'"
		unless(exists($pass_condition_for_type{$st_type}));

	my ($eval, @keys, $key, $val, $bool);

	local *sym;

	while(1)
		{
		$eval ='($key, $val) =
			each( %'.  $obj->[SYMBOL_TABLE_NAME] .');';
		debugging "eval is >>>$eval<<<";
		eval($eval);

		return undef unless(defined($key));
		next if($key =~ m{^(_|[^\w])});

		# main:: symbol table contains a reference to itself.
		# which means you get infinitely recursive symbol tables.
		# main::main::main::main:: etc
		# which isn't very useful.
		# if the key is 'main::' just ignore it and
		# look for the next one
		next if($key eq 'main::');

		my $boolean=0;

		$eval  = 'no warnings; no strict;';
		$eval .= ' *sym = $'.$st_name.'{'.$key.'}; ' ;
		$eval .= $pass_condition_for_type{$st_type};

		debugging "eval is >>>$eval<<<";
		eval($eval);

		debugging "boolean is $boolean";

		$key =~ s{::$}{};

		return $key if ($boolean);

		}

}


1;




1;
__END__