File Coverage

blib/lib/Hash/Subset.pm

Criterion	Covered	Total	%
statement	72	73	98.6
branch	38	40	95.0
condition			n/a
subroutine	14	14	100.0
pod	10	10	100.0
total	134	137	97.8

package Hash::Subset;

use strict;
use warnings;

use Exporter qw(import);

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2022-07-27'; # DATE
our $DIST = 'Hash-Subset'; # DIST
our $VERSION = '0.007'; # VERSION

our @EXPORT_OK = qw(
                       hash_subset
                       hashref_subset
                       hash_subset_without
                       hashref_subset_without

                       merge_hash_subset
                       merge_overwrite_hash_subset
                       merge_ignore_hash_subset
                       merge_hash_subset_without
                       merge_overwrite_hash_subset_without
                       merge_ignore_hash_subset_without
               );

sub _routine {
    my ($which, $hash, @keys_srcs) = @_;

    my $reverse = $which =~ /_without\z/;
    my $return_ref = $which =~ /\Ahashref_/;

    my %subset;
    %subset = %$hash if $reverse;

    for my $keys_src (@keys_srcs) {
        my $ref = ref $keys_src;
        if ($ref eq 'ARRAY') {
            if ($reverse) {
                for (@$keys_src) {
                    delete $subset{$_};
                }
            } else {
                for (@$keys_src) {
                    $subset{$_} = $hash->{$_} if exists $hash->{$_};
                }
            }
        } elsif ($ref eq 'HASH') {
            if ($reverse) {
                for (keys %$keys_src) {
                    delete $subset{$_};
                }
            } else {
                for (keys %$keys_src) {
                    $subset{$_} = $hash->{$_} if exists $hash->{$_};
                }
            }
        } elsif ($ref eq 'Regexp') {
            if ($reverse) {
                for (keys %subset) {
                    delete $subset{$_} if $_ =~ $keys_src;
                }
            } else {
                for (keys %$hash) {
                    $subset{$_} = $hash->{$_} if $_ =~ $keys_src;
                }
            }
        } elsif ($ref eq 'CODE') {
            if ($reverse) {
                for (keys %$hash) {
                    delete $subset{$_} if $keys_src->($_, $hash->{$_});
                }
            } else {
                for (keys %$hash) {
                    $subset{$_} = $hash->{$_} if $keys_src->($_, $hash->{$_});
                }
            }
        } else {
            die "Key source ($keys_src) must be a hashref/arrayref/Regexp/coderef";
        }
    } # for $keys_src

    if ($return_ref) {
        return \%subset;
    } else {
        return %subset;
    }
}

sub hash_subset    { _routine('hash_subset'   , @_) }
sub hashref_subset { _routine('hashref_subset', @_) }
sub hash_subset_without    { _routine('hash_subset_without'   , @_) }
sub hashref_subset_without { _routine('hashref_subset_without', @_) }

sub merge_hash_subset {
    my ($h1, $h2, @keys_src) = @_;
    my %subset = hash_subset($h2, @keys_src);
    for my $key (keys %subset) {
        die "Duplicate key when merging hash subset key '$key'" if exists $h1->{$key};
        $h1->{$key} = $subset{$key};
    }
}

sub merge_hash_subset_without {
    my ($h1, $h2, @keys_src) = @_;
    my %subset = hash_subset_without($h2, @keys_src);
    for my $key (keys %subset) {
        die "Duplicate key when merging hash subset key '$key'" if exists $h1->{$key};
        $h1->{$key} = $subset{$key};
    }
}

sub merge_overwrite_hash_subset {
    my ($h1, $h2, @keys_src) = @_;
    my %subset = hash_subset($h2, @keys_src);
    for my $key (keys %subset) {
        $h1->{$key} = $subset{$key};
    }
}

sub merge_overwrite_hash_subset_without {
    my ($h1, $h2, @keys_src) = @_;
    my %subset = hash_subset_without($h2, @keys_src);
    for my $key (keys %subset) {
        $h1->{$key} = $subset{$key};
    }
}

sub merge_ignore_hash_subset {
    my ($h1, $h2, @keys_src) = @_;
    my %subset = hash_subset($h2, @keys_src);
    for my $key (keys %subset) {
        next if exists $h1->{$key};
        $h1->{$key} = $subset{$key};
    }
}

sub merge_ignore_hash_subset_without {
    my ($h1, $h2, @keys_src) = @_;
    my %subset = hash_subset_without($h2, @keys_src);
    for my $key (keys %subset) {
        next if exists $h1->{$key};
        $h1->{$key} = $subset{$key};
    }
}

1;
# ABSTRACT: Produce subset of a hash

__END__