hash tools:

 

use 5.010;

# hash_tools.pm
# Advanced hash helper functions
# Fai Lau 2015

sub _print_children {
        my ($print_func, $str, %h) = @_;
        foreach (keys %h) {
                my $typ =  ref($h{$_});
                if ($typ ne 'HASH') {
                        my $s = $str . '|' . $_ . '|' . $h{$_};
   $print_func->($s);
                }
                else {
                        my %c = %{$h{$_}};
                        my $s = $str . '|' . $_;
                        &_print_children ($print_func, $s, %c);
                };
        }
}

#usage: &dumpHash (\&print_func, %h)
sub dumpHash {
 my $print_func = shift;
        my %h = @_;
        foreach (keys %h) {
                my %c = %{$h{$_}};
                &_print_children ($print_func, $_, %c);
        }
}

#usage: &getNodeFromHash (\%h, $k1, $k2, $k3,...) returns a reference
sub getNodeFromHash {
        my ($h, @k) = @_;
        for (@k) {
                $h = $h->{$_};
        }
        return $h;
}

#usage: &enumerateHash (\%h, \@keys, sub {my $h = shift;... })
# enumerate a hash using an array of keys and receive a reference in the callback function
sub enumerateHash {
 my($hash, $keys, $callback) = @_;
 my @keys = @$keys;
 my $dest = &getNodeFromHash ($hash, @keys);
 foreach (keys %$dest) {
  my $hh = $dest->{$_};
  $callback->($hh);
 }
}

sub _getNextLevel {
 my ($h, $k, $a) = @_;
 return unless ($h and $a);
 my $hs = scalar (keys %$h);
 return unless ($hs);
 my @def = @$k;
 my @keys = @def;
 if (scalar @keys < 1) {
  push @$a, $h;
  return;
 }
 my $key = shift @keys;
 if ($key eq '?') {
  foreach my $kk (keys %$h) {
   my $hh = $h->{$kk};
   _getNextLevel ($hh, \@keys, $a);
  }
 }
 else {
  my $hh = $h->{$key};
  if (scalar (keys %$hh) > 0) {
   _getNextLevel ($hh, \@keys, $a);
  }
 }
}

#usage: &getHashArray (\%h, $k1, $k2, $k3,...)
# returns an array of hash references using a set of keys - '?' means wildcard
sub getHashArray {
 my($hash, @keys) = @_;
 my @retval = ();
 _getNextLevel ($hash, \@keys, \@retval);
 return @retval;
}

sub _getNextLevelKeys {
 my ($h, @keys) = @_;
 return () unless (scalar @keys and $h and ref($h) eq 'HASH' and scalar (keys %$h));
 my $key = shift @keys;
 my @key_array = ();
 if ($key eq '?') {
  @key_array = keys %{$h};
 }
 else {
  @key_array = ($key);
 }
 my @retval = ();
 foreach my $kk (@key_array) {
  my $hh = $h->{$kk};
  my @a = _getNextLevelKeys($hh, @keys);
  if (@a) {
   foreach (@a) {
    my @aa = ($kk, @$_);
    push @retval, \@aa;
   }
  }
  else {
   my @aa = ($kk);
   push @retval, \@aa;
  }
 }
 return @retval;
}

#usage: &getKeySet (\%h, $k1, $k2, $k3,...)
# returns an array of array of keys from the hash - '?' means wildcard
sub getKeySet {
 my($hash, @keys) = @_;
 my @key_set = _getNextLevelKeys($hash, @keys);
 return @key_set;
}

1;