view release on metacpan or  search on metacpan

lib/Tie/SecureHash.pm  view on Meta::CPAN

                }
				
            }
            my $val = $self->{fullkeys}{$key};
            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 = CORE::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 (CORE::keys %sorted) {
        print "\n\t$class\n";
        foreach $key ( @{$sorted{$class}} ) {
            print "\t\t";
            print " '$key'\t=> '$self->{$key}'\n";
        }
    }
}


sub each($)	{ CORE::each %{$_[0]} }
sub keys($)	{ CORE::keys %{$_[0]} }
sub values($)	{ CORE::values %{$_[0]} }
sub exists($$)	{ CORE::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') && $ENV{UNSAFE_WARN};
    } 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;
    if (! $dangerous) {
        $entry = _access($self,$key,(caller)[0..1]);
    } elsif ($key =~ /::/) {
        $entry = \$self->{fullkeys}->{$key};
    } else {
        my $caller = (caller)[0];
        $entry = $self->_dangerous_access($key, $caller, 'FETCH');
    }
    return $$entry if $entry;
    return;
}

sub STORE {                       # ($self, $key, $value)
	my ($self, $key, $value) = @_;
	my $entry;
	if (! $dangerous) {
            $entry = _access($self,$key,(caller)[0..1]);
	} elsif ($key =~ /::/) {
            $self->{fullkeys}->{$key} = $value;
            $entry = \$self->{fullkeys}->{$key};
	} else {
            my $caller = (caller)[0];
            $entry = $self->_dangerous_access($key,$caller, 'STORE');
	}
	return $$entry = $value if $entry;
	return;
    }

sub DELETE {                      # ($self, $key)
    my ($self, $key) = @_;
    if (! $dangerous) {
        return _access($self,$key,(caller)[0..1],'DELETE');
    } 
    elsif ($key =~ /::/) {
        delete $self->{fullkeys}->{$key};
    } 
    else {
        my $caller = (caller)[0];
        return $self->_dangerous_access($key, $caller, 'DELETE');
    }
}


sub CLEAR {                     # ($self)
    my ($self) = @_;
    if ($dangerous) {
        %$self = ();
    }
    else {
        my ($caller, $file) = caller;
        my @inaccessibles =
            grep { ! eval { _access($self,$_,$caller,$file); 1 } }
                CORE::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) = @_;
        if (! $dangerous) {
            my @context = (caller)[0..1];
            eval { _access($self,$key,@context); 1 } ? 1 : '';
        }
        elsif ($key =~ /::/) {
            return exists $self->{fullkeys}->{$key};
        }
        else {
            my $caller = (caller)[0];
            _complain($self, $key, $caller, 'EXISTS') if $strict;
            return exists $self->{fullkeys}->{"$caller::$key"};
        }
    }

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

sub NEXTKEY                     # ($self)
    {
	my $self = $_[0];
        if ($dangerous) {
            return CORE::each %{$self->{fullkeys}};
        }
	my $key;
	my @context = (caller)[0..1];
	while (defined($key = CORE::each %{$self->{fullkeys}})) {
            last if eval { _access($self,$key,@context) };
            carp "Attempt to iterate inaccessible key '$key' will be unsafe in 'fast' mode. Use explicit keys" if $ENV{UNSAFE_WARN};
		     
	}
	return $key;
    }

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


1;
__END__

=head1 NAME

Tie::SecureHash - A tied hash that supports namespace-based encapsulation

=head1 VERSION

This document describes version 1.00 of Tie::SecureHash,
released December 3, 1998

=head1 CAVEAT

The original author of this module doesn't use it any more and it's
not recommended for new code.  Use L<Moo> or L<Moose> instead.  Newer
(2015) releases of this module are here to deal with unintended
consequences of the original implementation, and code that's not
easily moved away to more modern constructs.

=head1 SYNOPSIS

    use Tie::SecureHash;

    # CREATE A SECURE HASH

	my %hash;
	tie %hash, Tie::SecureHash;

    # CREATE A REFERENCE TO A SECURE HASH (BLESSED INTO Tie::SecureHash!)

	my $hashref = Tie::SecureHash->new();

    # CREATE A REFERENCE TO A SECURE HASH (BLESSED INTO $some_other_class)

	my $hashref = Tie::SecureHash->new($some_other_class);

    # CREATE NEW ENTRIES IN THE HASH

	package MyClass;

	sub new
	{
		my ($class, %args) = @_
		my $self = Tie::SecureHash->new($class);