File Coverage

blib/lib/Tie/ShadowHash.pm

Criterion	Covered	Total	%
statement	92	99	92.9
branch	34	40	85.0
condition	9	12	75.0
subroutine	12	13	92.3
pod	1	3	33.3
total	148	167	88.6

# Tie::ShadowHash -- Merge multiple data sources into a hash.
#
# Copyright 1999, 2002, 2010 by Russ Allbery
#
# This program is free software; you may redistribute it and/or modify it
# under the same terms as Perl itself.
#
# This module combines multiple sources of data into a single tied hash, so
# that they can all be queried simultaneously, the source of any given
# key-value pair irrelevant to the client script.  Data sources are searched
# in the order that they're added to the shadow hash.  Changes to the hashed
# data aren't propagated back to the actual data files; instead, they're saved
# within the tied hash and override any data obtained from the data sources.

##############################################################################
# Modules and declarations
##############################################################################

package Tie::ShadowHash;
require 5.006;

use strict;
use vars qw($VERSION);

$VERSION = '1.00';

##############################################################################
# Regular methods
##############################################################################

# This should pretty much never be called; tie calls TIEHASH.
sub new {
    my $class = shift;
    return $class->TIEHASH (@_);
}

# Given a file name and optionally a split regex, builds a hash out of the
# contents of the file.  If the split sub exists, use it to split each line
# into an array; if the array has two elements, those are taken as the key and
# value.  If there are more, the value is an anonymous array containing
# everything but the first.  If there's no split sub, take the entire line
# modulo the line terminator as the key and the value the number of times it
# occurs in the file.
sub text_source {
    my ($self, $file, $split) = @_;
    unless (open (HASH, '<', $file)) {
        require Carp;
        Carp::croak ("Can't open file $file: $!");
    }
    local $_;
    my ($key, @rest, %hash);
    while () {
        chomp;
        if (defined $split) {
            ($key, @rest) = &$split ($_);
            $hash{$key} = (@rest == 1) ? $rest[0] : [ @rest ];
        } else {
            $hash{$_}++;
        }
    }
    close HASH;
    return \%hash;
}

# Add data sources to the shadow hash.  This takes a list of either anonymous
# arrays (in which case the first element is the type of source and the rest
# are arguments), filenames (in which case it's taken to be a text file with
# each line being a key), or hash references (possibly to tied hashes).
sub add {
    my ($self, @sources) = @_;
    for my $source (@sources) {
        if (ref $source eq 'ARRAY') {
            my ($type, @args) = @$source;
            if ($type eq 'text') {
                $source = $self->text_source (@args);
            } else {
                require Carp;
                Carp::croak ("Invalid source type $type");
            }
        } elsif (!ref $source) {
            $source = $self->text_source ($source);
        }
        push (@{ $$self{SOURCES} }, $source);
    }
    return 1;
}

##############################################################################
# Tie methods
##############################################################################

# DELETED is a hash holding all keys that have been deleted; it's checked
# first on any access.  EACH is a pointer to the current structure being
# traversed on an "each" of the shadow hash, so that they can all be traversed
# in order.  OVERRIDE is a hash containing values set directly by the user,
# which override anything in the shadow hash's underlying data structures.
# And finally, SOURCES is an array of the data structures (all Perl hashes,
# possibly tied).
sub TIEHASH {
    my $class = shift;
    $class = ref $class || $class;
    my $self = {
        DELETED  => {},
        EACH     => -1,
        OVERRIDE => {},
        SOURCES  => []
    };
    bless ($self, $class);
    $self->add (@_) if @_;
    return $self;
}

# Note that this doesn't work quite right in the case of keys with undefined
# values, but we can't make it work right since that would require using
# exists and a lot of common data sources (such as NDBM_File tied hashes)
# don't implement exists.
sub FETCH {
    my ($self, $key) = @_;
    return if $self->{DELETED}{$key};
    return $self->{OVERRIDE}{$key} if exists $self->{OVERRIDE}{$key};
    for my $source (@{ $self->{SOURCES} }) {
        return $source->{$key} if defined $source->{$key};
    }
    return;
}

sub STORE {
    my ($self, $key, $value) = @_;
    delete $self->{DELETED}{$key};
    $self->{OVERRIDE}{$key} = $value;
}

sub DELETE {
    my ($self, $key) = @_;
    delete $self->{OVERRIDE}{$key};
    $self->{DELETED}{$key} = 1;
}

sub CLEAR {
    my ($self) = @_;
    $self->{DELETED} = {};
    $self->{OVERRIDE} = {};
    $self->{SOURCES} = [];
    $self->{EACH} = -1;
}

# This could throw an exception if any underlying source doesn't support
# exists (like NDBM_File).
sub EXISTS {
    my ($self, $key) = @_;
    return if exists $self->{DELETED}{$key};
    for my $source ($self->{OVERRIDE}, @{ $self->{SOURCES} }) {
        return 1 if exists $source->{$key};
    }
    return;
}

# We have to reset the each counter on all hashes.  For tied hashes, we call
# FIRSTKEY directly because it's potentially more efficient than calling keys
# on the hash.
sub FIRSTKEY {
    my ($self) = @_;
    keys %{ $self->{OVERRIDE} };
    for my $source (@{ $self->{SOURCES} }) {
        my $tie = tied $source;
        if ($tie) {
            $tie->FIRSTKEY;
        } else {
            keys %$source;
        }
    }
    $self->{EACH} = -1;
    return $self->NEXTKEY;
}

# Walk the sources by calling each on each one in turn, skipping deleted
# keys and keys shadowed by earlier hashes and using $self->{EACH} to
# store the number of source we're at.
sub NEXTKEY {
    my ($self) = @_;
    my @result = ();
  SOURCE:
    while (!@result && $self->{EACH} < @{ $self->{SOURCES} }) {
        if ($self->{EACH} == -1) {
            @result = each %{ $self->{OVERRIDE} };
        } else {
            @result = each %{ $self->{SOURCES}[$self->{EACH}] };
        }
        if (@result && $self->{DELETED}{$result[0]}) {
            undef @result;
            next;
        }
        if (@result && $self->{EACH} > -1) {
            my $key = $result[0];
            if (exists $self->{OVERRIDE}{$key}) {
                undef @result;
                next;
            }
            for (my $index = $self->{EACH} - 1; $index >= 0; $index--) {
                if (defined $self->{SOURCES}[$index]{$key}) {
                    undef @result;
                    next SOURCE;
                }
            }
        }
        return (wantarray ? @result : $result[0]) if @result;
        $self->{EACH}++;
    }
    return;
}

##############################################################################
# Module return value and documentation
##############################################################################

# Make sure the module returns true.
1;

__DATA__