File Coverage

blib/lib/Tie/ShadowHash.pm

Criterion	Covered	Total	%
statement	88	90	97.7
branch	32	34	94.1
condition	3	6	50.0
subroutine	14	14	100.0
pod	1	1	100.0
total	138	145	95.1

# Tie::ShadowHash -- Merge multiple data sources into a hash.
#
# 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.
#
# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl

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

package Tie::ShadowHash 2.01;

use 5.024;
use autodie;
use warnings;

use Carp qw(croak);

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

# 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.
#
# $file  - File containing the data
# $split - Optional anonymous sub that splits a line into key and value
#
# Returns: Hash created by loading the file
sub _text_source {
    my ($self, $file, $split) = @_;
    my %hash;
    open(my $fh, '<', $file);
    while (defined(my $line = <$fh>)) {
        chomp($line);
        if (defined($split)) {
            my ($key, @rest) = $split->($line);
            $hash{$key} = (@rest == 1) ? $rest[0] : [@rest];
        } else {
            $hash{$line}++;
        }
    }
    close($fh);
    return \%hash;
}

# Add data sources to the shadow hash.
#
# Each data source is one of the following:
#
# - An anonymous array, in which case the first element is the type of source
#   and the rest are arguments.  Currently, "text" is the only supported type.
#
# - A file name, which is taken to be a text file with each line as a key and
#   a value equal to the number of times that line appears.
#
# - A hash reference, possibly to a tied hash.
#
# @sources - Data sources to add
#
# Returns: True
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 {
                croak("invalid source type $type");
            }
        } elsif (!ref($source)) {
            $source = $self->_text_source($source);
        }
        push($self->{SOURCES}->@*, $source);
    }
    return 1;
}

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

# Create a new tied hash.
#
# @sources - Sources to add to the new hash
#
# Returns: Newly created tied hash
sub TIEHASH {
    my ($class, @sources) = @_;
    $class = ref($class) || $class;
    #<<<
    my $self = {
        DELETED  => {},  # All keys that have been deleted
        EACH     => -1,  # Index of source currently being traversed
        OVERRIDE => {},  # Values set directly by the user
        SOURCES  => [],  # Array of all of the underlying hashes
    };
    #>>>
    bless($self, $class);
    $self->add(@sources);
    return $self;
}

# Retrieve a value.
#
# 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.
#
# $key - Key to look up
#
# Returns: Value for that key, undef if it is not present
sub FETCH {
    my ($self, $key) = @_;
    if ($self->{DELETED}{$key}) {
        return;
    } elsif (exists($self->{OVERRIDE}{$key})) {
        return $self->{OVERRIDE}{$key};
    } else {
        for my $source ($self->{SOURCES}->@*) {
            if (defined($source->{$key})) {
                return $source->{$key};
            }
        }
        return;
    }
}

# Store a value.  This goes into the override hash, which is checked before
# any of the underlying data sources.
#
# $key   - Key to store a value for
# $value - Value to store
sub STORE {
    my ($self, $key, $value) = @_;
    delete $self->{DELETED}{$key};
    $self->{OVERRIDE}{$key} = $value;
    return;
}

# Delete a key.  The key is flagged in the deleted hash, which ensures that
# undef will be returned for any future retrieval.  Dropping the override
# value isn't required for currect future FETCH behavior, but it drops the
# reference so that memory can be released.
#
# $key - Key to delete
sub DELETE {
    my ($self, $key) = @_;
    delete $self->{OVERRIDE}{$key};
    $self->{DELETED}{$key} = 1;
    return;
}

# Clear the hash.  Removes all sources and all overrides and resets any
# iteration.
sub CLEAR {
    my ($self) = @_;
    $self->{DELETED} = {};
    $self->{OVERRIDE} = {};
    $self->{SOURCES} = [];
    $self->{EACH} = -1;
    return;
}

# Return whether a key exists.
#
# This could throw an exception if any underlying source doesn't support
# exists (like NDBM_File).
#
# $key - Key to query for existence
#
# Returns: True if the key exists, false otherwise
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;
}

# Start an iteration.
#
# 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();
}

# Iterate through the hashes.
#
# 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.
#
# Returns: Next key in iteration, or undef if sources are exhausted
sub NEXTKEY {
    my ($self) = @_;

    # EACH is the numeric index in the SOURCES list for the source we're
    # currently calling each on, or -1 if we're just starting and thus
    # operating on the OVERRIDE hash.
    #
    # We have to loop until we find the next value, which may take several
    # iterations since keys could have been overridden by an earlier hash or
    # deleted.
  SOURCE:
    while ($self->{EACH} < $self->{SOURCES}->@*) {
        my $key;

        ## no critic (Each)
        if ($self->{EACH} == -1) {
            $key = each($self->{OVERRIDE}->%*);
        } else {
            $key = each($self->{SOURCES}[$self->{EACH}]->%*);
        }
        ## use critic

        # If we got a valid result, we have to check against DELETED,
        # OVERRIDE, and all earlier sources before returning it.
        if (defined($key)) {
            if ($self->{DELETED}{$key}) {
                next;
            } elsif ($self->{EACH} >= 0 && exists($self->{OVERRIDE}{$key})) {
                next;
            } elsif ($self->{EACH} > 0) {
                for my $index (reverse(0 .. $self->{EACH} - 1)) {
                    if (defined($self->{SOURCES}[$index]{$key})) {
                        next SOURCE;
                    }
                }
            }
            return $key;
        }
        $self->{EACH}++;
    }

    # We have exhausted all of the sources.
    return;
}

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

# Make sure the module returns true.
1;

__DATA__