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__

=head1 NAME

Tie::Hash::KeysMask
- Control key aliasing by mask function, e.g. omit case of character distinction

=head1 SYNOPSIS

    use Tie::Hash::KeysMask;

    my $mask = sub {...};
    tie %argH, 'Tie::Hash::KeyMask',$mask, more arguments;

     Yield that the key mask function &$mask translates any key
     when applied to %argH like ..

            $k   =>   $mask->($k, more arguments)

     that is

             $argH{$k}  expands to  $argH{$mask->($k, more arguments)}
        $argH{$k} = $v  expands to  $argH{$mask->($k, more arguments)} = $v


=head1 DESCRIPTION

If e.g. choose key mask  C<sub {uc $_[0]}> one can access an element
without care of case of the key.
In place of C<sub {  }> particular items can be used which will be translated
into a CODE. The translation is

            'lc' => sub { lc $_[0] }
            'uc' => sub { uc $_[0] }
            \%M  => sub { exists $M{$_[0]} ? $M{$_[0]} : $_[0]}

A class-method C<codemap> manage this translation. If it is pleased one
could override it and add ones own translations.

This class inherits from C<Tie::Hash::Create> by which the tied hash can
be obtained anonymously as reference with the command

            'Tie::Hash::KeyMask'->newHASH (sub {...}, more arguments)

which overrides the tie syntax calling tie from body of newHash.

=head1 SEE ALSO

L<Tie::Hash::Create>, L<Sub::ParamFrame>.

=head1  CAVEATS

The mask function must satisfy this rule: Each of different keys which
are considered as equal must be mapped to one and the same value only.
Hence, if \&mask is given as agument of the construtor, no triple of
different keys $a,$b,$c such that $b = mask($a) and $c = mask($b) are
admitted. It's ease to receive counter examples which break this rule
using certain hashs for mask in order to observe funny results.

=head1 PREREQUISITES

This module requires these other modules and libraries: C<Tie::Hash::Create>

=head1 AUTHOR

Josef SchE<ouml>nbrunner E<lt>j.schoenbrunner@onemail.atE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (c) 2005  by Josef SchE<ouml>nbrunner
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.7 or,
at your option, any later version of Perl 5 you may have available.

=cut