File Coverage

blib/lib/Type/Tie/Aggregate/Hash.pm

Criterion	Covered	Total	%
statement	25	27	92.5
branch	2	4	50.0
condition			n/a
subroutine	9	9	100.0
pod			n/a
total	36	40	90.0

# ABSTRACT: class to tie hashes for Type::Tie::Aggregate

######################################################################
# Copyright (C) 2021 Asher Gordon                 #
#                                                                    #
# This program is free software: you can redistribute it and/or      #
# modify it under the terms of the GNU General Public License as     #
# published by the Free Software Foundation, either version 3 of     #
# the License, or (at your option) any later version.                #
#                                                                    #
# This program is distributed in the hope that it will be useful,    #
# but WITHOUT ANY WARRANTY; without even the implied warranty of     #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU   #
# General Public License for more details.                           #
#                                                                    #
# You should have received a copy of the GNU General Public License  #
# along with this program. If not, see                               #
# .                                    #
######################################################################

package Type::Tie::Aggregate::Hash;
$Type::Tie::Aggregate::Hash::VERSION = '0.001';
#pod =head1 DESCRIPTION
#pod
#pod This class is used to tie hashes. This class is internal to
#pod L.
#pod
#pod =cut

use v5.6.0;
use strict;
use warnings;
use namespace::autoclean;
use Carp;
use parent 'Type::Tie::Aggregate::Base';

sub _create_ref {
    shift;
    if (@_ % 2) {
	carp 'Odd number of elements in hash initialization';
	push @_, undef;
    }
    +{ @_ };
}

sub _check_value {
    my (undef, $value) = @_;
    return 'Not a HASH reference' unless ref $value eq 'HASH';
    return;
}

sub TIEHASH { my $class = shift; $class->_new(@_) }

__PACKAGE__->_install_methods(
    { mutates => 1 },
    STORE	=> '$ref->{$_[0]} = $_[1]',
    DELETE	=> 'delete $ref->{$_[0]}',
    CLEAR	=> '%$ref = ()',
);

__PACKAGE__->_install_methods(
    { mutates => 0 },
    FETCH	=> '$ref->{$_[0]}',
    FIRSTKEY	=> 'scalar keys %$ref; each %$ref',
    NEXTKEY	=> 'each %$ref',
    EXISTS	=> 'exists $ref->{$_[0]}',
    SCALAR	=> 'scalar %$ref',
);

#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L
#pod
#pod =cut

1;

__END__