File Coverage

lib/Hash/MostUtils.pm

Criterion	Covered	Total	%
statement	100	101	99.0
branch	3	4	75.0
condition	3	6	50.0
subroutine	29	29	100.0
pod	11	11	100.0
total	146	151	96.6

use strict;
use warnings;
package Hash::MostUtils;
use base qw(Exporter);

use Carp qw(confess);
use Hash::MostUtils::leach qw(n_each leach);

our $VERSION = 1.07;

our @EXPORT_OK = qw(
  lvalues
  lkeys
  leach
  hash_slice_of
  hash_slice_by
  hashmap
  hashgrep
  hashapply
  hashsort
  n_each
  n_map
  n_grep
  n_apply
  reindex
  rekey
  revalue
);

# decrementing $| flips it between 0 and 1
sub lkeys   { local $|; return grep { $|-- == 0 } @_ }
sub lvalues { local $|; return grep { $|-- == 1 } @_ }

# I would put leach() here, but it was imported above

*hashmap = sub(&@) { unshift @_, 2; goto &n_map };
*hashgrep = sub(&@) { unshift @_, 2; goto &n_grep };
*hashapply = sub (&@) { unshift @_, 2; goto &n_apply };

sub hashsort (&@) {
  my $sort = shift;

  my $caller = caller;
  no strict 'refs';

  return
    map { ($_->{key} => $_->{value}) }
    sort {
      local (${"$caller\::a"}, ${"$caller\::b"}) = ($a, $b);
      $sort->();
    }
    &hashmap(sub { +{key => $a, value => $b} }, @_);
}

# I would put n_each() here, but it was imported above

sub n_map ($&@) {
  # Usually I don't mutate @_. Here I deliberately modify @_ for the upcoming non-obvious goto-&NAME.
  my $n = shift;
  my $collector = sub { return $_[0]->() };
  unshift @_, $collector;

  # Using a "safe goto" allows n_map() to remove itself from the callstack, which allows _n_collect()
  # to see the correct caller.
  #
  # 'perldoc -f goto' for why this is a safe goto.
  goto &{_n_collect($n)};
}

sub n_grep ($&@) {
  my $n = shift;

  # the comments in n_map() apply here as well.

  my $collector = sub {
    my ($code, $vals, $aliases) = @_;
    return $code->() ? @$vals : ();
  };
  unshift @_, $collector;

  goto &{_n_collect($n)};
}

sub n_apply {
  my $n = shift;
  my $collector = sub {
    my ($code, $vals, $aliases) = @_;
    $code->();
    return map { $$_ } @$aliases;
  };
  unshift @_, $collector;

  goto &{_n_collect($n)};
}

sub _n_collect($) {
  my ($n) = @_;
  return sub(&@) {
    my $collector = shift;
    my $code = shift;
    if (@_ % $n != 0) {
      confess("your input is insane: can't evenly slice " . @_ . " elements into $n-sized chunks\n");
    }

    # these'll reserve some namespace back in the callpackage
    my @n = ('a' .. 'z');

    # stash old values back in callpackage *and* in main. If called from main::, this comes down to:
    #   local ${'main::a'}, ${'main::b'}, ${'main::c'}
    # when $n is 3.
    my $caller = caller;
    no strict 'refs';
    foreach ((@n[ 0 .. $n-1 ])) {
      local ${"::$_"};
    }

    my @out;
    while (my @chunk = splice @_, 0, $n) {  # build up each set...
      my @aliases;
      foreach (0 .. $#chunk) {
        # ...assign values from @_ back to localized variables in $caller *and* in 'main::'.
        # Aliasing in main::  allows you to refer to variables $c and onwards as $::c.
        # Aliasing in $caller allows you to refer to variables $c and onwards as $whatever::package::c.
        ${"::$n[$_]"} = ${"$caller\::$n[$_]"} = $chunk[$_];

        # Keep a reference to $::a (etc.) and pass them in to the $collector; this allows $code to mutate
        # $::a (etc) and signal the changed values back to $collector.
        push @aliases, \$ {"::$n[$_]"};
      }
      push @out, $collector->($code, \@chunk, \@aliases);             # ...and apply $code.
    }

    return @out;
  };
}

sub hash_slice_of {
  my ($ref, @keys) = @_;
  return map { ($_ => $ref->{$_}) } @keys;
}

sub hash_slice_by {
  my ($obj, @methods) = @_;
  return map { ($_ => scalar($obj->$_)) } @methods;
}

sub rekey (&@) {
  my %map = shift()->();
  return n_map 2, sub { $map{$a} || $a => $b }, @_;
}

sub reindex (&@) {
  my %map = shift()->();
  @_[values %map] = delete @_[keys %map];
  return @_;
}

sub revalue (&@) {
  my %map = shift()->();
  return n_map 2, sub { $a => $map{$b} || $b }, @_;
}

1;

__END__