File Coverage

blib/lib/Tie/Hash/Method.pm

Criterion	Covered	Total	%
statement	46	68	67.6
branch	7	16	43.7
condition			n/a
subroutine	15	23	65.2
pod	7	7	100.0
total	75	114	65.7

package Tie::Hash::Method;
use strict;
use warnings;
use base 'Exporter';

=head1 NAME

Tie::Hash::Method - Tied hash with specific methods overriden by callbacks

=head1 VERSION

Version 0.02

=cut

our $VERSION= '0.02';
$VERSION= eval $VERSION;    # just in case we have a dev release
our @EXPORT_OK= qw(tie_hash_method HASH METHOD PRIVATE);

use constant HASH => 0;
use constant METHOD => 1;
use constant PRIVATE => 2;
use Data::Dumper;

# not overridable obviously.
sub TIEHASH {
    my $class= shift;
    my %opts= @_;
    #die Dumper
    bless [
            {}, #HASH
            +{ map { $_ => $opts{$_} } grep {$_ eq uc($_) } keys %opts }, #METHOD
            +{ map { $_ => $opts{$_} } grep {$_ ne uc($_) } keys %opts }, #PRIVATE
           ], $class;
}

sub FETCH {
    if ( my $cb= $_[0][METHOD]->{FETCH} ) {
        return $cb->(@_);
    } else {
        return $_[0][HASH]->{ $_[1] };
    }
}

sub STORE {
    if ( my $cb= $_[0][METHOD]->{STORE} ) {
        return $cb->(@_);
    } else {
        return $_[0][HASH]->{ $_[1] }= $_[2];
    }
}

sub EXISTS {
    if ( my $cb= $_[0][METHOD]->{EXISTS} ) {
        return $cb->(@_);
    } else {
        exists $_[0][HASH]->{ $_[1] };
    }
}

sub DELETE {
    if ( my $cb= $_[0][METHOD]->{DELETE} ) {
        return $cb->(@_);
    } else {
        delete $_[0][HASH]->{ $_[1] };
    }
}


sub FIRSTKEY {
    if ( my $cb= $_[0][METHOD]->{FIRSTKEY} ) {
        return $cb->(@_);
    } else {
        # reset iterator
        my $val= scalar keys %{ $_[0][HASH] };
        return each %{ $_[0][HASH] };
    }
}

sub NEXTKEY {
    if ( my $cb= $_[0][METHOD]->{NEXTKEY} ) {
        return $cb->(@_);
    } else {
        return each %{ $_[0][HASH] };
    }
}


sub CLEAR {
    if ( my $cb= $_[0][METHOD]->{CLEAR} ) {
        return $cb->(@_);
    } else {
        return %{ $_[0][HASH] }= ();
    }
}

sub SCALAR {
    if ( my $cb= $_[0][METHOD]->{SCALAR} ) {
        return $cb->(@_);
    } else {
        return scalar %{ $_[0][HASH] };
    }
}

sub methods {
    return grep { $_ ne 'hash' } keys %{ $_[0][METHOD] };
}

sub method_hash : lvalue { $_[0][METHOD] }

sub base_hash : lvalue { $_[0][HASH] }
sub h         : lvalue { $_[0][HASH] }
sub private_hash : lvalue { $_[0][PRIVATE] }
sub p            : lvalue { $_[0][PRIVATE] }

sub hash_overload {
    tie my %hash, __PACKAGE__, @_;
    return \%hash;
}

1;    #make require happy

__END__