File Coverage

blib/lib/Hook/Modular/Walker.pm

Criterion	Covered	Total	%
statement	42	61	68.8
branch	15	48	31.2
condition	1	12	8.3
subroutine	13	15	86.6
pod	4	4	100.0
total	75	140	53.5

use 5.008;
use strict;
use warnings;

package Hook::Modular::Walker;
BEGIN {
  $Hook::Modular::Walker::VERSION = '1.101050';
}
# ABSTRACT: Methods that walk over the workflow
use Carp;
use Scalar::Util qw(blessed);
use UNIVERSAL;

sub new {
    my $class = shift;
    my $self = @_ ? {@_} : {};
    bless $self, $class;
}
*isa = \&UNIVERSAL::isa;

sub decode_utf8 {
    my ($self, $stuff) = @_;
    $self = $self->new(apply_keys => 1) unless ref $self;
    $self->apply(sub { utf8::decode($_[0]) unless utf8::is_utf8($_[0]) })
      ->($stuff);
}

sub apply($&;@) {    ## no critic
    my $self   = shift;
    my $code   = shift;
    my $keyapp = $self->{apply_keys} ? sub { $code->(shift) } : sub { shift };
    my $curry;       # recursive so can't init
    $curry = sub {
        my @retval;
        for my $arg (@_) {
            my $class = ref $arg;
            croak 'blessed reference forbidden'
              if !$self->{apply_blessed} and blessed $arg;
            my $val =
                !$class ? $code->($arg)
              : isa($arg, 'ARRAY') ? [ $curry->(@$arg) ]
              : isa($arg, 'HASH')
              ? { map { $keyapp->($_) => $curry->($arg->{$_}) } keys %$arg }
              : isa($arg, 'SCALAR') ? \do { $curry->($$arg) }
              : isa($arg, 'REF') && $self->{apply_ref} ? \do { $curry->($$arg) }
              : isa($arg, 'GLOB') ? *{ $curry->(*$arg) }
              : isa($arg, 'CODE') && $self->{apply_code} ? $code->($arg)
              :   croak "I don't know how to apply to $class";
            bless $val, $class if blessed $arg;
            push @retval, $val;
        }
        return wantarray ? @retval : $retval[0];
    };
    @_ ? $curry->(@_) : $curry;
}

sub serialize {
    shift;   # we don't need the class
    my $stuff = shift;
    my $curry;
    $curry = sub {
        my @retval;
        for my $arg (@_) {
            my $class = ref $arg;
            my $val =
                blessed $arg && $arg->can('serialize') ? $arg->serialize
              : !$class ? $arg
              : isa($arg, 'ARRAY') ? [ $curry->(@$arg) ]
              : isa($arg, 'HASH')
              ? { map { $_ => $curry->($arg->{$_}) } keys %$arg }
              : isa($arg, 'SCALAR') ? \do { $curry->($$arg) }
              : isa($arg, 'REF')    ? \do { $curry->($$arg) }
              : isa($arg, 'GLOB')   ? *{ $curry->(*$arg) }
              : isa($arg, 'CODE')   ? $arg
              :   croak "I don't know how to apply to $class";
            push @retval, $val;
        }
        return wantarray ? @retval : $retval[0];
    };
    $curry->($stuff->clone);
}
1;


__END__