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];} ;
            $mf = { 'lc'=> sub {lc $_[0]}, 'uc'=> sub {uc $_[0]} }->{$mf} ;


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

     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];

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

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

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

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



=head1 NAME

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


    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


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.


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>


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.