File Coverage

blib/lib/Tie/SecureHash.pm

Criterion	Covered	Total	%
statement	171	258	66.2
branch	107	158	67.7
condition	15	35	42.8
subroutine	18	23	78.2
pod	3	6	50.0
total	314	480	65.4

package Tie::SecureHash;

use strict;
our ($VERSION, $strict, $fast, $dangerous, $loud);
use Carp;

$VERSION = '1.10';

sub import {
    my ($pkg, @args) = @_;
    my $args = join(' ', @args);
    $strict = $args =~ /\bstrict\b/;
    $fast   = $args =~ /\bfast\b/;
    $dangerous = $args =~ /\bdangerous\b/;
    $loud = $args =~ /\bloud\b/;
    croak qq{$pkg can't be both "strict" and "fast"} if $strict && $fast;
    $strict = 1 if $loud;
}

# TAKE A LIST OF POSSIBLE CLASSES FOR AN IMPLICIT KEY AND REMOVE NON-CONTENDERS

sub _winnow {
    my ($caller, $nonpublic, @classes) = @_;

    # REMOVE CLASSES NOT IN HIERARCHY FOR NON-PUBLIC KEY

    @classes = grep { $caller->isa($_) } @classes if $nonpublic;

    # COMPARE REMAINING KEYS PAIRWISE, ELIMINATING "SHADOWED" KEYS...

  I: for(my $i=0; $i<$#classes; )
	{
          J: for(my $j=$i+1; $j<@classes; )
		{
                    if ($classes[$j]->isa($classes[$i])) {
			# CLASS J SHADOWS I FROM $caller
                        if ($caller->isa($classes[$j])) {
                            splice @classes,$i,1;
                            next I;
                        }
			# CLASS J BELOW CALLING PACKAGE
			# (SO CALLING PACKAGE COULDN'T INHERIT IT)
                        elsif ($classes[$j]->isa($caller)) {
                            splice @classes,$j,1;
                            next J;
                        }
                    } elsif ($classes[$i]->isa($classes[$j])) {
			# CLASS I SHADOWS J FROM $caller
                        if ($caller->isa($classes[$i])) {
                            splice @classes,$j,1;
                            next J;
                        }
			# CLASS I BELOW CALLING PACKAGE
			# (SO CALLING PACKAGE COULDN'T INHERIT IT)
                        elsif ($classes[$i]->isa($caller)) {
                            splice @classes,$i,1;
                            next I;
                        }
                    }
                    $j++;

		}
            $i++;
	}

    return @classes;
}
;

# DETERMINE IF A KEY IS ACCESSIBLE

sub _access {
    my ($self, $key, $caller, $file, $delete) = @_;

    # EXPLICIT KEYS...

    if ($key =~ /\A([\w:]*)::((_{0,2})[^:]+)\Z/) {
        my ($classname, $shortkey, $mode) = ($1,$2,$3);
        unless ($classname)
            {
                $classname = 'main';
                $key = $classname.$key;
            }
        if ($mode eq '__')	# PRIVATE
            {
                croak "Private key $key of tied securehash inaccessible from package $caller"
                    unless $classname eq $caller;
                if (exists $self->{fullkeys}{$key}) {
                    croak "Private key $key of tied securehash inaccessible from file $file"
                        if $self->{file}{$key} ne $file;
                } else {
                    if ($delete) {
                        delete $self->{file}{$key};
                    } else {
                        $self->{file}{$key} = $file;
                    }
                }
            } elsif ($mode eq '_') # PROTECTED
		{
                    croak "Protected key $key of tied securehash inaccessible from package $caller"
                        unless $caller->isa($classname);
		}

        if (!exists $self->{fullkeys}{$key}) {
            croak "Entry for key $key of tied securehash cannot be created " .
                "from package $caller"
                    if $classname ne $caller && !$delete;
            if ($delete) {
                @{$self->{keylist}{$shortkey}} =
                    grep { $_ !~ /$classname/ }
                        @{$self->{keylist}{$shortkey}}
                    } else {
                        push @{$self->{keylist}{$shortkey}}, $classname;
                    }
        }
    }

    # IMPLICIT PRIVATE KEY (MUST BE IN CALLING CLASS)
    elsif ($key =~ /\A(__[^:]+)\Z/) {
        carp qq{Accessing securehash via unqualified key {"$key"}\n}.
            qq{will be unsafe in 'fast' mode. Use {"${caller}::$key"}}
                if $strict && $ENV{UNSAFE_WARN};
        if (!exists $self->{fullkeys}{"${caller}::$key"}) {
            croak "Private key '$key' of tied securehash is inaccessible from package $caller"
                if exists $self->{keylist}{$key};
            croak "Private key '${caller}::$key' does not exist in tied securehash"
        }
        $key = "${caller}::$key";
        if (exists $self->{fullkeys}{$key}) {
            croak "Private key $key of tied securehash inaccessible from file $file"
                if $self->{file}{$key} ne $file;
        }
    }

    # IMPLICIT PROTECTED OR PUBLIC KEY
    # (PROTECTED KEY MUST BE IN ANCESTRAL HIERARCHY OF CALLING CLASS)
    elsif ($key =~ /\A((_?)[^:]+)\Z/) {
        my $fullkey = "${caller}::$key";
        carp qq{Accessing securehash via unqualified key {"$key"}\n}.
            qq{will be unsafe in 'fast' mode. Use {"${caller}::$key"}}
                if $strict && $ENV{UNSAFE_WARN};
        if (exists $self->{fullkeys}{$fullkey}) {
            $key = $fullkey;
        } else {
            my @classes = _winnow($caller, $2,
                                  @{$self->{keylist}{$key}||[]});

            if (@classes) {
				# TOO MANY CHOICES
                croak "Ambiguous key '$key' (when accessed "
                    . "from package $caller).\nCould be:\n"
                        . join("", map {"\t${_}::$key\n"} @classes)
                            . " "
                                if @classes > 1;
                $key = $classes[0]."::$key";
            } else              # NOT ENOUGH CHOICES
                {
                    croak +($2?"Protected":"Public")." key '$key' of tied securehash is inaccessible from package $caller"
                        if exists $self->{keylist}{$key};
                    croak +($2?"Protected":"Public")." key '${caller}::$key' does not exist in tied securehash";
                }
        }
    } else                      # INVALID KEY
	{
            croak "Invalid key '$key'";
	}

    if ($delete) {
        return delete $self->{fullkeys}{$key};
    }
    return \$self->{fullkeys}{$key};
}

sub _dangerous_access {
    my ($self,$key,$caller, $action) = @_;
    _complain(@_) if $strict;
    require mro;
    my @isa = @{mro::get_linear_isa($caller)}; # mro seems to return a weird read only arrayref
    pop @isa if $isa[-1] eq 'Exporter';
    my @candidate_keys = map { "$_::$key" } @isa;
    my $val;
    foreach my $k (@candidate_keys) {
        if ($action eq 'DELETE') {
            my $deleted;
            if (exists $self->{fullkeys}->{$k}) {
                delete $self->{fullkeys}->{$k};
                $deleted = 1;
            }
            last if $deleted;
        } else {
            $val = $self->{fullkeys}->{$k};
            last if $val;
        }
    }
    return \$val;
}

sub _complain { # override complain with Role::Tiny to customise dump.
    my ($self, $key, $caller, $action) = @_;
    $DB::single=1;
    carp "Ran an expensive dangerous $action due to unqualified key $key being sent in to hash for $caller" if $strict;
    if ($loud) {
        require Data::Dumper;
        Data::Dumper->import;
        carp Dumper ($self->{fullkeys});
    }
}

# NOTE THAT NEW MAY TIE AND BLESS INTO THE SAME CLASS
# IF NOTHING MORE APPROPRIATE IS SPECIFIED

sub new {
    my %self = ();
    my $class =  ref($_[0])||$_[0];
    my $blessclass =  ref($_[1])||$_[1]||$class;
    my $impl = tie %self, $class unless $fast;
    my $self = bless \%self, $blessclass;
    splice(@_,0,2);
    if (@_)                     # INITIALIZATION ARGUMENTS PRESENT
	{
            my ($ancestor, $file);
            my $i = 0;
            while ( ($ancestor,$file) = caller($i++) ) {
                last if $ancestor eq $blessclass;
            }
            $file = "" if ! defined $file; # dms 14 Mar 2000: satisfy -w switch
            my ($key, $value);
            while (($key,$value) = splice(@_,0,2)) {
                my $fullkey = $key=~/::/ ? $key : "${blessclass}::$key";
                if ($fast) {
                    $self->{$fullkey} = $value;
                } else {
                    $impl->{fullkeys}{$fullkey} = $value;
                    push @{$impl->{keylist}{$key}}, $blessclass;
                    $impl->{file}{$fullkey} = $file
                        if $key =~ /\A__/;
                }
            }
	}

    return $self;
}

# USEFUL METHODS TO DUMP INFORMATION

sub debug {
    my $self = tied %{$_[0]};
    my ($caller, $file, $line, $sub) = (caller,(caller(1))[3]||"(none)");
    return _simple_debug($_[0],$caller, $file, $line, $sub) unless $self;
    my ($key, $val);
    my %sorted = ();
    while ($key = CORE::each %{$self->{fullkeys}}) {
        $key =~ m/\A(.*?)([^:]*)\Z/;
        push @{$sorted{$1}}, $key;
    }

    print STDERR "\nIn subroutine '$sub' called from package '$caller' ($file, line $line):\n";
    foreach my $class (CORE::keys %sorted) {
        print STDERR "\n\t$class\n";
        foreach $key ( @{$sorted{$class}} ) {
            print STDERR "\t\t";
            my ($shortkey) = $key =~ /.*::(.*)/;
            my $explanation = "";
            if (eval { _access($self,$shortkey,$caller, $file); 1 }) {
                print STDERR '(+)';
            } elsif ($@ =~ /\AAmbiguous key/) {
                print STDERR '(?)';
                ($explanation = $@) =~ s/.*\n//;
                $explanation =~ s/.*\n\Z//;
                $explanation =~ s/\ACould/Ambiguous unless fully qualified. Could/;
                $explanation =~ s/^(?!\Z)/\t\t\t>>> /gm;
            } else {
                print STDERR '(-)';
                if ($shortkey =~ /\A__/ && $@ =~ /file/) {
                    $explanation = "\t\t\t>>> Private entry of $class\n\t\t\t>>> declared in file $self->{file}{$key}\n\t\t\t>>> is inaccessable from file $file.\n"
                } elsif ($shortkey =~ /\A__/) {
                    $explanation = "\t\t\t>>> Private entry of $class\n\t\t\t>>> is inaccessable from package $caller.\n"
                } else {
                    $explanation = "\t\t\t>>> Protected entry of $class\n\t\t\t>>> is inaccessible outside its hierarchy (i.e. from $caller).\n"
                }

            }
            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__