view release on metacpan or  search on metacpan

InSecureHash.pm  view on Meta::CPAN

			if (defined $val) { $val = "'$val'" }
			else { $val = "undef" }
			print STDERR " '$shortkey'\t=> $val";
			print STDERR "\n$explanation" if $explanation;
			print STDERR "\n";
		}
	}
}

sub _simple_debug
{
	my ($self,$caller, $file, $line, $sub) = @_;
	my ($key, $val);
	my %sorted = ();
	while ($key = each %{$self})
	{
		$key =~ m/\A(.*?)([^:]*)\Z/;
		push @{$sorted{$1}}, $key;
	}

	print "\nIn subroutine '$sub' called from package '$caller' ($file, line $line):\n";
	foreach my $class (keys %sorted)
	{
		print "\n\t$class\n";
		foreach $key ( @{$sorted{$class}} )
		{
			print "\t\t";
			print " '$key'\t=> '$self->{$key}'\n";
		}
	}
}


sub each	{ each %{$_[0]} }
sub keys	{ keys %{$_[0]} }
sub values	{ values %{$_[0]} }
sub exists	{ exists $_[0]->{$_[1]} }

sub TIEHASH	# ($class, @args)
{
	my $class = ref($_[0]) || $_[0];
	if ($strict)
	{
		carp qq{Tie'ing a securehash directly will be unsafe in 'fast' mode.\n}.
		     qq{Use Tie::SecureHash::new instead}
			unless (caller 1)[3] =~ /\A(.*?)::([^:]*)\Z/
			    && $2 eq "new"
			    && $1->isa('Tie::SecureHash');
	}
	elsif ($fast)
	{
		carp qq{Tie'ing a securehash directly should never happen in 'fast' mode.\n}.
		     qq{Use Tie::SecureHash::new instead}
	}
	bless {}, $class;
}

sub FETCH	# ($self, $key)
{
	my ($self, $key) = @_;
	my $entry = _access($self,$key,(caller)[0..1]);
	return $$entry if $entry;
	return;
}

sub STORE	# ($self, $key, $value)
{
	my ($self, $key, $value) = @_;
	my $entry = _access($self,$key,(caller)[0..1]);
	return $$entry = $value if $entry;
	return;
}

sub DELETE	# ($self, $key)
{
	my ($self, $key) = @_;
	return _access($self,$key,(caller)[0..1],'DELETE');
}

sub CLEAR	# ($self)
{
	my ($self) = @_;
	my ($caller, $file) = caller;
	my @inaccessibles =
		grep { ! eval { _access($self,$_,$caller,$file); 1 } }
			keys %{$self->{fullkeys}};
	croak "Unable to assign to securehash because the following existing keys\nare inaccessible from package $caller and cannot be deleted:\n" .
		join("\n", map {"\t$_"} @inaccessibles) . "\n "
			if @inaccessibles;
	%{$self} = ();
}

sub EXISTS	# ($self, $key)
{
	my ($self, $key) = @_;
	my @context = (caller)[0..1];
	eval { _access($self,$key,@context); 1 } ? 1 : '';
}

sub FIRSTKEY	# ($self)
{
	my ($self) = @_;
	keys %{$self->{fullkeys}};
	goto &NEXTKEY;
}

sub NEXTKEY	# ($self)
{
	my $self = $_[0];
	my $key;
	my @context = (caller)[0..1];
	while (defined($key = each %{$self->{fullkeys}}))
	{
		last if eval { _access($self,$key,@context) };
	}
	return $key;
}

sub DESTROY	# ($self)
{
	# NOTHING TO DO
	# (BE CAREFUL SINCE IT DOES DOUBLE DUTY FOR tie AND bless)
}


1;
__END__

=head1 NAME

Tie::InSecureHash

=head2 DESCRIPTION

Tie::InSecureHash - A tied hash that is API compatible with
L<Tie::SecureHash> with namespace-based encapsulation features
disabled.  This is for debugging.  Typically you'll use this in the
following manner:

    #!/usr/bin/env perl
    use warnings;
    use strict;
    BEGIN {
        if ($ENV{STUPID_AND_DANGEROUS}) {
            use lib 't/naughty_lib';
        }
    }
    use Tie::SecureHash;

Then in t/naughty_lib:

    package Tie::SecureHash;
    use base Tie::InSecureHash;
    1;

Now you can use things like L<Devel::Cycle> (temporarily) in your code ...

=head1 VERSION

This code derived form v1.03 of Tie::SecureHash released in 1999.


=head2 ACCESS RESTRICTIONS ON ENTRIES

There are none.  This code is for debugging only :P

=head1 AUTHOR

Damian Conway (damian@cs.monash.edu.au)

Swathes of code deletions by Kieren Diment <zarquon@cpan.org> with help from