File Coverage

blib/lib/Tie/Subset/Hash.pm

Criterion	Covered	Total	%
statement	65	66	100.0
branch	23	24	100.0
condition	3	3	100.0
subroutine	14	14	100.0
pod			n/a
total	105	107	100.0

#!perl
package Tie::Subset::Hash;
use warnings;
use strict;
use warnings::register;
use Carp;

# For AUTHOR, COPYRIGHT, AND LICENSE see the bottom of this file

=head1 Name

Tie::Subset::Hash - Tie a hash to a subset of another hash

=head1 Synopsis

 use Tie::Subset::Hash;
 my %hash = ( foo=>11, bar=>22, quz=>33 );
 tie my %subset, 'Tie::Subset::Hash', \%hash, ['bar','quz'];
 print "$subset{bar}\n";  # prints "22"
 $subset{quz}++;          # modifies $hash{quz}

=head1 Description

This class for tied hashes provides a "view" of a subset of a hash.

=over

=cut

our $VERSION = '0.02';

=item Cing

 tie my %subset, 'Tie::Subset::Hash', \%hash, \@keys;

You must specify which subset of keys from the original hash can
be accessed via the tied hash. (Keys that do not yet exist in the
original hash may be specified.)

=cut

sub TIEHASH {  ## no critic (RequireArgUnpacking)
	@_==3 or croak "bad number of arguments to tie";
	my ($class, $hash, $keys) = @_;
	ref $hash eq 'HASH' or croak "must provide hashref to tie";
	ref $keys eq 'ARRAY' or croak "must provide key list to tie";
	for (@$keys) { croak "bad hash key '$_'" if ref; croak "bad hash key undef" if !defined }
	my $self = { hash => $hash, keys => { map {$_=>1} @$keys } };
	return bless $self, $class;
}

=item Fetching

If the key is in the subset, the value from the underlying hash is
returned, otherwise returns nothing (undef).

=cut

sub FETCH {
	my ($self,$key) = @_;
	return unless exists $self->{keys}{$key};
	return $self->{hash}{$key};
}

=item Storing

If the key is in the subset, the new value will be stored in the
underlying hash, otherwise the operation is ignored and a warning
issued.

=cut

sub STORE {
	my ($self,$key,$val) = @_;
	if (exists $self->{keys}{$key}) {
		return $self->{hash}{$key} = $val;
	} # else
	warnings::warnif("assigning to unknown key '$key' not (yet) supported in ".ref($self).", ignoring");
	return;
}

=item C

Will return true only if the key is in the subset I it exists
in the underlying hash.

=cut

sub EXISTS {
	my ($self,$key) = @_;
	# need to write this in this slightly strange way because otherwise
	# the code coverage tool isn't picking it up correctly...
	if ( exists $self->{keys}{$key} && exists $self->{hash}{$key} )
		{ return !!1 } else { return !!0 }
}

=item Iterating (C, C, etc.)

Only keys that exist both in the subset I the underlying hash
are iterated over. The iterator of the underlying hash is utilized,
so iterating over the tied hash will affect the state of the iterator
of the underlying hash.

=cut

sub FIRSTKEY {
	my ($self) = @_;
	my $dummy = keys %{$self->{keys}};  # reset iterator
	return $self->NEXTKEY;
}
sub NEXTKEY {
	my ($self,$lkey) = @_;
	my $next;
	SEEK: {
		$next = each %{$self->{keys}};
		return unless defined $next;
		redo SEEK unless exists $self->{hash}{$next};
	}
	return $next;
}

=item Cing

If the key is in the subset, the key will be deleted from the
underlying hash, but not the subset. Otherwise, the operation is
ignored and a warning issued.

=cut

sub DELETE {
	my ($self,$key) = @_;
	if (exists $self->{keys}{$key}) {
		return delete $self->{hash}{$key};
	} # else
	warnings::warnif("deleting unknown key '$key' not (yet) supported in ".ref($self).", ignoring");
	return;
}

=item Clearing

Not (yet) supported (because it is ambiguous whether this operation
should delete keys from the underlying hash or not). Attempting to
clear the tied hash currently does nothing and causes a warning
to be issued.

A future version of this module may lift this limitation (if a
useful default behavior exists).

=cut

sub CLEAR {
	my ($self) = @_;
	warnings::warnif("clearing of ".ref($self)." not (yet) supported, ignoring");
	return;
}

sub SCALAR {
	my ($self) = @_;
	# I'm not sure why the following counts as two statements in the coverage tool
	# uncoverable branch true
	# uncoverable statement count:2
	return scalar %{$self->{keys}} if $] lt '5.026';
	my %keys = map {$_=>1} grep {exists $self->{hash}{$_}} keys %{$self->{keys}};
	return scalar keys %keys;
}

sub UNTIE {
	my ($self) = @_;
	$self->{hash} = undef;
	$self->{keys} = undef;
	return;
}

1;
__END__