File Coverage

blib/lib/HTML/FormHandler/Merge.pm

Criterion	Covered	Total	%
statement	25	25	100.0
branch	12	12	100.0
condition			n/a
subroutine	5	5	100.0
pod	0	2	0.0
total	42	44	95.4

package HTML::FormHandler::Merge;
# ABSTRACT: internal hash merging
$HTML::FormHandler::Merge::VERSION = '0.40068';
use warnings;
use Data::Clone;
use base 'Exporter';

our @EXPORT_OK = ( 'merge' );

our $matrix = {
    'SCALAR' => {
        'SCALAR' => sub { $_[0] },
        'ARRAY'  => sub { [ $_[0], @{ $_[1] } ] },
        'HASH'   => sub { $_[1] },
    },
    'ARRAY' => {
        'SCALAR' => sub { [ @{ $_[0] }, $_[1] ] },
        'ARRAY'  => sub { [ @{ $_[0] }, @{ $_[1] } ] },
        'HASH'   => sub { $_[1] },
    },
    'HASH' => {
        'SCALAR' => sub { $_[0] },
        'ARRAY'  => sub { $_[0] },
        'HASH'   => sub { merge_hashes( $_[0], $_[1] ) },
    },
};

sub merge {
    my ( $left, $right ) = @_;

    my $lefttype =
        ref $left eq 'HASH'  ? 'HASH' :
        ref $left eq 'ARRAY' ? 'ARRAY' :
                               'SCALAR';
    my $righttype =
        ref $right eq 'HASH'  ? 'HASH' :
        ref $right eq 'ARRAY' ? 'ARRAY' :
                                'SCALAR';
    $left  = clone($left);
    $right = clone($right);
    return $matrix->{$lefttype}{$righttype}->( $left, $right );
}

sub merge_hashes {
    my ( $left, $right ) = @_;
    my %newhash;
    foreach my $leftkey ( keys %$left ) {
        if ( exists $right->{$leftkey} ) {
            $newhash{$leftkey} = merge( $left->{$leftkey}, $right->{$leftkey} );
        }
        else {
            $newhash{$leftkey} = clone( $left->{$leftkey} );
        }
    }
    foreach my $rightkey ( keys %$right ) {
        if ( !exists $left->{$rightkey} ) {
            $newhash{$rightkey} = clone( $right->{$rightkey} );
        }
    }
    return \%newhash;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

HTML::FormHandler::Merge - internal hash merging

=head1 VERSION

version 0.40068

=head1 AUTHOR

FormHandler Contributors - see HTML::FormHandler

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2017 by Gerda Shank.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut