/usr/local/CPAN/Tie-Hash-ReadonlyStack/Tie/Hash/ReadonlyStack.pm

• package Tie::Hash::ReadonlyStack
  • clear_compiled_cache
  • add_lookup_override_hash_without_clearing_cache
  • add_lookup_override_hash
  • add_lookup_fallback_hash
  • del_lookup_hash
  • get_keys_not_in_stack
  • TIEHASH
  • STORE
  • DELETE
  • CLEAR
  • EXISTS
  • FETCH
  • SCALAR
  • FIRSTKEY
  • NEXTKEY
  • UNTIE
• EOF

package Tie::Hash::ReadonlyStack;

# use warnings;
use strict;

$Tie::Hash::ReadonlyStack::VERSION = '0.2';

sub clear_compiled_cache {
    my ( $self, @keys ) = @_;
    
    if (@keys) {
        my $count = 0;
        for my $k (@keys) {
            if (exists $self->{'compiled'}{$k}) {
                delete $self->{'compiled'}{$k} if exists $self->{'compiled'}{$k};
                $count++;
            }
        }
        return $count if $count;
        return;
    }
    else {
        %{ $self->{'compiled'} } = (); 
        return 1;
    }
}

sub add_lookup_override_hash_without_clearing_cache {
    my ( $self, $name, $hr ) = @_;
    
    return if $name eq 'readonly_hash';
    return if exists $self->{'hashes'}{$name};

    unshift @{ $self->{'order'} }, $name;
    $self->{'hashes'}{$name} = $hr;
}

sub add_lookup_override_hash {
    my ( $self, $name, $hr ) = @_;
    
    if ( !tied(%{$hr}) ) { 
        $self->clear_compiled_cache(keys %{$hr});
    }
    else {
        for my $key ( keys %{ $self->{'compiled'} } ) {
            if ( exists $self->{'compiled'}{$key} ) {
                delete $self->{'compiled'}{$key};
            }
        }
    }
    
    return $self->add_lookup_override_hash_without_clearing_cache($name, $hr);
}

sub add_lookup_fallback_hash {
    my ( $self, $name, $hr ) = @_;
    return if $name eq 'readonly_hash';
    return if exists $self->{'hashes'}{$name};

    push @{ $self->{'order'} }, $name;
    $self->{'hashes'}{$name} = $hr;
}

sub del_lookup_hash {
    my ( $self, $name, $only_if_exists ) = @_;
    return if $name eq 'readonly_hash';
    return if $only_if_exists && !exists $self->{'hashes'}{$name};

    delete $self->{'hashes'}{$name};
    @{ $self->{'order'} } = grep { $_ ne $name } @{ $self->{'order'} };
    for my $key ( keys %{ $self->{'compiled'} } ) {
        if ( exists $self->{'compiled'}{$key}{'found_in'} && $self->{'compiled'}{$key}{'found_in'} eq $name ) {
            delete $self->{'compiled'}{$key};
        }
    }
    return 1;
}

sub get_keys_not_in_stack {
    my ($self) = @_;

    return map { !exists $self->{'compiled'}{$_}{'found_in'} ? $_ : () } keys %{ $self->{'compiled'} };
}

sub TIEHASH {
    my ( $class, $mainhash ) = @_;
    return bless {
        'compiled' => {},
        'hashes'   => { 'readonly_hash' => $mainhash },
        'order'    => ['readonly_hash']
    }, $class;
}

# tied to a read only handle (gdbm) or one you do not want updated (DBI) ?
sub STORE {
    my ( $self, $key, $val ) = @_;
    $self->{'compiled'}{$key}{'value'} = $val;
}

sub DELETE {
    my ( $self, $key ) = @_;
    return if !exists $self->{'compiled'}{$key};

    my $val = $self->{'compiled'}{$key}{'value'};

    delete $self->{'compiled'}{$key};
    return $val;
}

sub CLEAR {
    my ($self) = @_;
    delete $self->{'compiled'};

    for my $hash_name ( @{ $self->{'order'} } ) {
        next if $hash_name eq 'readonly_hash';
        untie $self->{'hashes'}{$hash_name} if tied( $self->{'hashes'}{$hash_name} );
        delete $self->{'hashes'}{$hash_name};
    }
}

sub EXISTS {
    my ( $self, $key ) = @_;

    return 1 if exists $self->{'compiled'}{$key} && exists $self->{'compiled'}{$key}{'value'};

    for my $hash_name ( @{ $self->{'order'} } ) {
        return 1 if exists $self->{'hashes'}{$hash_name}{$key};
    }

    return;
}

sub FETCH {
    my ( $self, $key ) = @_;

    return $self->{'compiled'}{$key}{'value'} if exists $self->{'compiled'}{$key} && exists $self->{'compiled'}{$key}{'value'};

    for my $hash_name ( @{ $self->{'order'} } ) {
        if ( exists $self->{'hashes'}{$hash_name}{$key} ) {
            $self->{'compiled'}{$key}{'found_in'} = $hash_name;
            $self->{'compiled'}{$key}{'value'}    = $self->{'hashes'}{$hash_name}{$key};
            return $self->{'compiled'}{$key}{'value'};
        }
    }

    return;
}

sub SCALAR {
    return scalar %{ shift->{'compiled'} };
}

sub FIRSTKEY {
    my $self = shift;
    my $c    = keys %{ $self->{'compiled'} };    # reset each() iterator
    each %{ $self->{'compiled'} };
}

sub NEXTKEY {
    return each %{ shift->{'compiled'} };
}

sub UNTIE {
    my $self = shift;
    delete $self->{'compiled'};
    for my $hash_name ( @{ $self->{'order'} } ) {
        untie $self->{'hashes'}{$hash_name} if tied( $self->{'hashes'}{$hash_name} );
        delete $self->{'hashes'}{$hash_name};
    }
    delete $self->{'order'};
    delete $self->{'hashes'};
}

# sub DESTROY {
#     my $self = shift;
# }

1;