SCALAR=Some value
LIST=Foo,Bar,Baz
HASH=Foo:Bar,Baz:Quux

##</code><code>##

DOMAIN=@example.com
USER=sAMAccountName.DOMAIN
PASS=md5sum(PRE.sAMAccountName.POST,15)
PRE=a874f4u
POST=ea748tyoal
MAIL=join(DOT,givenName,sn).DOMAIN

##</code><code>##

%h = (
    DOMAIN => '@example.com',
    USER   => sub { $r->{sAMAcountName} . $c->{DOMAIN} },
    PASS   => sub { md5sum($c->{PRE} . $r->{sAMAcountName} . $c->{POST}, 15) },
    MAIL   => sub { join('.', $r->{givenName}, $r->{sn}).$c->{DOMAIN} },
);

##</code><code>##

$out{$key} = $h{$key}->();

##</code><code>##

%out = %h;

##</code><code>##

package Sub::Hash;

use strict;
use warnings;

use Tie::Hash;
our @ISA = qw(Tie::ExtraHash);

our $VERSION = '0.01';

sub TIEHASH  {
    my $class = shift;
    my $sub   = shift;
    if(ref $sub) {
        $sub  =~ /\bCODE\(/
            or die "$class\::TIEHASH: not a code reference: '$_[0]', aborted";
    } else {
        my $pack = caller;
        my $s = $pack->can($sub)
            or die "Can't find subroutine \&$pack\::$sub, aborted";
        $sub = $s;
    }
    my $storage = bless [{}, {}, $sub, map{\$_} @_], $class;
    $storage;
}

sub FETCH {
    my $self = shift;
    my $shash = $self->[0];
    my $vhash = $self->[1];
    my $key  = shift;
    my $value = $vhash->{$key};
    ref( $shash->{$key} ) =~ /\bCODE\b/
        ? $shash->{$key}->($key, $value, $self, map{$$_}@{$self}[3..$#$self])
        : $value;
}
sub STORE {
    my $self   = shift;
    my $key    = $_[0];
    my $shash  = $self->[0];
    my $vhash  = $self->[1];
    my $gensub = $self->[2];
    $vhash->{$key} = $_[1];
    unless ($shash->{$key}) {
        my $sub = $gensub->(@_,$self, map{$$_}@{$self}[3..$#$self]);
        $shash->{$key} = $sub if ref $sub eq 'CODE';
    }
}

# accessors for the instance members

sub subhash { $_[0][0] };
sub valhash { $_[0][1] };
sub sub     { $_[0][0]->{$_[1]} }
sub value   {
    if(exists $_[2]) {
        $_[0][1]->{$_[1]} = $_[2];
    }
    $_[0][1]->{$_[1]};
}
sub gensub {
    my $self = shift;
    if (@_) {
        my $sub = shift;
        if(ref $sub) {
            $sub =~ /\bCODE\b/ or die "not a CODE reference, aborted";
        } else {
            my $pack = caller;
            my $s = $pack->can($sub)
                or die "Can't find subroutine \&$pack\::$sub, aborted";
        }
        $self->[2] = $sub;
    }
    $self->[2];
}
sub params {
    my $self = shift;
    if (@_) {
        splice @$self, 3, $#$self, map {\$_} @_;
    }
    map {$$_} @$self[3..$#$self];
}

1;
__END__

=head1 NAME

Sub::Hash - tie generated subroutines to keys of a hash

=head1 SYNOPSIS


    use Sub::Hash;

    tie %hash, Sub::Hash, qw(gensub), $additonal, $variable;

    sub gensub {
      my ($key,$value, $additional, $variable) = @_;
      ...
      return $code;
    }

    # also
    $gensub = sub {
      my ($key,$value, $additional, $variable) = @_;
      ...
      return $code;
    };
    tie %hash, Sub::Hash, $gensub, $additonal, $variable;

=head1 DESCRIPTION

This package implements a hash table whose values are anonymous subroutines.
These subroutines are generated by the subroutine passed to tie() as the third
argument when a value is allocated for a key. This subroutine generating
subroutine gets the key/value pair as the first arguments, followed the object 
which is returned by tied(%hash) on the tied %hash, then by any additional
variables passed to tie() after the subroutine argument.

Accessing a value results in execution of its associated subroutine, which gets
the same arguments as the the generating subroutine. If the subroutine slot is
empty, the content of the value slot is returned instead.

While the scalar values in a hash slot may be changed like in any other hash,
the associated subroutine remains in place after generation (but see below).
Additional methods to access the components of the object returned by the call
to tie() or tied(%hash) are described below.

=head1 CONSTRUCTOR

The generating subroutine may be passed as an anonymous sub (or CODE reference)
or as a literal to tie(), in which case the subroutine is looked up in the
caller's package.

Additional variables are stored as references to the arguments of the
constructor, which means that their reference count increases,  and remain in
place even after their lexical scope ends.

=head1 METHODS

=over 4

=item subhash

returns the anonumous hash holding the value subroutines

=item valhash

returns the anonymous hash holding the scalar values

=item sub($key [,$sub])

gets or sets the anonymous subroutine stored under $key

=item value($key [,$scalar])

gets or sets the scalar value stored in the hash under $key

=item gensub 

Gets or sets the subroutine generating subroutine.

=item params

gets or sets the additional parameters passed to the tie() call.
Setting them replaces the original parameters, so their reference
count is decreased.

=back

=head1 EXAMPLE

    use Sub::Hash;
    my ($closed,$over) = qw(closed over);
    my $gensub = sub {
        my ($key,$value,$w,$x) = @_;
        return sub {
            my($key,$value,$y,$z) = @_;
            return "closed over:\n"
                  . "- tied vars at creation: ('$w','$x')\n"
                  . "- key = $key\n"
                  . "modifyable:\n"
                  . "- value = $value\n"
                  . "- tied variables: ($y,$z)\n";
        }
    };
    my $obj = tie %hash, Sub::Hash, $gensub, $closed, $over;
    my $key = 'foo';
    my $result = $hash{$key} = 'bar'; # generates the subroutine and executes it
    print $result,"-----\n";
    
    ($closed,$over) = ('open','til late');
    $result = $hash{$key};          # executes sub stored under $key,
                                    # passing it ($key,$value,$obj,$closed,$over)
    print $result,"-----\n";
    
    $result = $hash{$key} = 'quux';
    print $result,"-----\n";
    
    __END__
    
    Results of the above code:
    
    closed over:
    - tied vars at creation: ('closed','over')
    - key = foo
    modifyable:
    - value = bar
    - tied variables: (closed,over)
    -----
    closed over:
    - tied vars at creation: ('closed','over')
    - key = foo
    modifyable:
    - value = bar
    - tied variables: (open,til late)
    -----
    closed over:
    - tied vars at creation: ('closed','over')
    - key = foo
    modifyable:
    - value = quux
    - tied variables: (open,til late)
    -----

=head1 SEE ALSO

Tie::Hash, perltie, Tie::Sub

=head1 AUTHOR

Georg Moritz, E<lt>shmem@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2015 by Georg Moritz

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.


=cut