File Coverage

blib/lib/Tie/Hash/KeysMask.pm

Criterion	Covered	Total	%
statement	15	15	100.0
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	20	20	100.0

package slot;

 sub KM() {4}

package Tie::Hash::KeysMask;

use 5.008007;
our $VERSION = 0.01;
use strict;
#no strict 'subs';
no strict 'refs';
use Carp;
our @ISA;
use base ('Tie::Hash::Create');

    sub codemap
    {
         my $class = shift;
         croak 'codemap not for object!' if ref($class);
         croak 'missing argument' unless @_;

         my $mf = shift;

         return $mf if ref($mf) eq 'CODE';

         if ( ref($mf) eq 'HASH' )
         {
            my $transl = $mf;
            $mf = sub { exists $transl->{$_[0]} ? $transl->{$_[0]} : $_[0];} ;
         }
         else
         {
            $mf = { 'lc'=> sub {lc $_[0]}, 'uc'=> sub {uc $_[0]} }->{$mf} ;
         };

         $mf;
    }

#use Trace::Caller ':all';
#use Data::Dumper;

sub TIEHASH
{
     my ($class,$mf) = splice @_,0,2;
     $mf = codemap($class,$mf);
     #$mf = preamb::codemap $mf;

     croak 'Parameter of type CODE or NULL required here!'
             unless $mf && (ref($mf) eq 'CODE');
    # structure of the created object (the one also accessed by tied(%array))
    # ----------------------------------------------------------------------
    # ARRAY                                              Contents e.g.
    # ----------------------------------------------------------------------
    # 0  internal reference to the tied hash             generated by tie
    # 1  real reference to the tied hash                 \%H
    # 2  status flag. reserved for planned subclass.     0
    # 3  slot for default values.  used by subclass.     [...,Name=>Value,...]
    # 4  CODE the keymask function                       sub {...}
    # 5  fixed arguments for call of the keymask function
    # 6> free
    # ----------------------------------------------------------------------
    # loc.   0 1 2       3      4 #| 2:defaults | 3:&mask | 4:fix arguments to mask
     bless [{},undef,0,undef, $mf, [@_]], $class;
}

sub transKey
{
    #print Dumper[$_[0]];
    #printf 'transkey uses (%d) %s%s',slot::KM,ref($_[0][slot::KM]),qq(\n);
    $_[0][slot::KM]? $_[0][slot::KM]->($_[1],@{$_[0][slot::KM+1]}): $_[1];
}

sub STORE
{
    $_[0][0]{transKey @_} = $_[2];
}

sub FETCH
{
    $_[0][0]{transKey @_};
}

sub DELETE
{
    delete $_[0][0]{transKey @_};
}

sub EXISTS
{
    exists $_[0][0]{transKey @_};
}

1;

__END__