File Coverage

blib/lib/Operator/Util.pm

Criterion	Covered	Total	%
statement	124	129	96.1
branch	90	104	86.5
condition	33	33	100.0
subroutine	14	15	93.3
pod	8	8	100.0
total	269	289	93.0

package Operator::Util;

use 5.006;
use strict;
use warnings;
use parent 'Exporter';
use List::MoreUtils qw( uniq );

our $VERSION   = '0.05';
our @EXPORT_OK = qw(
    reduce  reducewith
    zip     zipwith
    cross   crosswith
    hyper   hyperwith
    applyop reverseop
);
our %EXPORT_TAGS = ( all => \@EXPORT_OK );

*reducewith = \&reduce;
*hyperwith  = \&hyper;

# sub: operator subroutines
# res: responses in an arrayref for when zero or one argument is provided --
#      the first element is the response for zero args and the second is for
#      one arg, defaulting to the arg itself
# chain: set non-chaining Perl 5 operator to chaining-associative
# right: set operator to right-associative

my %ops = (
    # binary infix
    'infix:**'  => { sub => sub { $_[0] **  $_[1] }, res => [1], right => 1 },
    'infix:=~'  => { sub => sub { $_[0] =~  $_[1] }, res => [1, 1] },
    'infix:!~'  => { sub => sub { $_[0] !~  $_[1] }, res => [1, 1] },
    'infix:*'   => { sub => sub { $_[0] *   $_[1] }, res => [1] },
    'infix:/'   => { sub => sub { $_[0] /   $_[1] }, res => [undef] },
    'infix:%'   => { sub => sub { $_[0] %   $_[1] }, res => [undef] },
    'infix:x'   => { sub => sub { $_[0] x   $_[1] }, res => [undef] },
    'infix:+'   => { sub => sub { $_[0] +   $_[1] }, res => [0] },
    'infix:-'   => { sub => sub { $_[0] -   $_[1] }, res => [0] },
    'infix:.'   => { sub => sub { $_[0] .   $_[1] }, res => [''] },
    'infix:<<'  => { sub => sub { $_[0] <<  $_[1] }, res => [undef] },
    'infix:>>'  => { sub => sub { $_[0] >>  $_[1] }, res => [undef] },
    'infix:<'   => { sub => sub { $_[0] <   $_[1] }, res => [1, 1], chain => 1 },
    'infix:>'   => { sub => sub { $_[0] >   $_[1] }, res => [1, 1], chain => 1 },
    'infix:<='  => { sub => sub { $_[0] <=  $_[1] }, res => [1, 1], chain => 1 },
    'infix:>='  => { sub => sub { $_[0] >=  $_[1] }, res => [1, 1], chain => 1 },
    'infix:lt'  => { sub => sub { $_[0] lt  $_[1] }, res => [1, 1], chain => 1 },
    'infix:gt'  => { sub => sub { $_[0] gt  $_[1] }, res => [1, 1], chain => 1 },
    'infix:le'  => { sub => sub { $_[0] le  $_[1] }, res => [1, 1], chain => 1 },
    'infix:ge'  => { sub => sub { $_[0] ge  $_[1] }, res => [1, 1], chain => 1 },
    'infix:=='  => { sub => sub { $_[0] ==  $_[1] }, res => [1, 1], chain => 1 },
    'infix:!='  => { sub => sub { $_[0] !=  $_[1] }, res => [1, 1], chain => 1 },
    'infix:<=>' => { sub => sub { $_[0] <=> $_[1] }, res => [1, 1], chain => 1 },
    'infix:eq'  => { sub => sub { $_[0] eq  $_[1] }, res => [1, 1], chain => 1 },
    'infix:ne'  => { sub => sub { $_[0] ne  $_[1] }, res => [1, 1], chain => 1 },
    'infix:cmp' => { sub => sub { $_[0] cmp $_[1] }, res => [1, 1], chain => 1 },
    'infix:&'   => { sub => sub { $_[0] &   $_[1] }, res => [-1] },
    'infix:|'   => { sub => sub { $_[0] |   $_[1] }, res => [0] },
    'infix:^'   => { sub => sub { $_[0] ^   $_[1] }, res => [0] },
    'infix:&&'  => { sub => sub { $_[0] &&  $_[1] }, res => [1] },
    'infix:||'  => { sub => sub { $_[0] ||  $_[1] }, res => [0] },
    'infix:..'  => { sub => sub { $_[0] ..  $_[1] }, res => [1] },
    'infix:...' => { sub => sub { $_[0] ... $_[1] }, res => [1] },
    'infix:='   => { sub => sub { $_[0] =   $_[1] }, res => [undef] },
    'infix:**=' => { sub => sub { $_[0] **= $_[1] }, res => [undef] },
    'infix:*='  => { sub => sub { $_[0] *=  $_[1] }, res => [undef] },
    'infix:/='  => { sub => sub { $_[0] /=  $_[1] }, res => [undef] },
    'infix:%='  => { sub => sub { $_[0] %=  $_[1] }, res => [undef] },
    'infix:x='  => { sub => sub { $_[0] x=  $_[1] }, res => [undef] },
    'infix:+='  => { sub => sub { $_[0] +=  $_[1] }, res => [undef] },
    'infix:-='  => { sub => sub { $_[0] -=  $_[1] }, res => [undef] },
    'infix:.='  => { sub => sub { $_[0] .=  $_[1] }, res => [undef] },
    'infix:<<=' => { sub => sub { $_[0] <<= $_[1] }, res => [undef] },
    'infix:>>=' => { sub => sub { $_[0] >>= $_[1] }, res => [undef] },
    'infix:&='  => { sub => sub { $_[0] &=  $_[1] }, res => [undef] },
    'infix:|='  => { sub => sub { $_[0] |=  $_[1] }, res => [undef] },
    'infix:^='  => { sub => sub { $_[0] ^=  $_[1] }, res => [undef] },
    'infix:&&=' => { sub => sub { $_[0] &&= $_[1] }, res => [undef] },
    'infix:||=' => { sub => sub { $_[0] ||= $_[1] }, res => [undef] },
    'infix:,'   => { sub => sub { $_[0] ,   $_[1] }, res => [[]] },
    'infix:=>'  => { sub => sub { $_[0] =>  $_[1] }, res => [[]] },
    'infix:and' => { sub => sub { $_[0] and $_[1] }, res => [1] },
    'infix:or'  => { sub => sub { $_[0] or  $_[1] }, res => [0] },
    'infix:xor' => { sub => sub { $_[0] xor $_[1] }, res => [0] },
    'infix:->'  => { sub => sub { my $m = $_[1];         $_[0]->$m }, res => [undef] },
    'infix:->=' => { sub => sub { my $m = $_[1]; $_[0] = $_[0]->$m }, res => [undef] },

    # unary prefix
    'prefix:++' => { sub => sub { ++$_[0]  } },
    'prefix:--' => { sub => sub { --$_[0]  } },
    'prefix:!'  => { sub => sub {  !$_[0]  } },
    'prefix:~'  => { sub => sub {  ~$_[0]  } },
    'prefix:\\' => { sub => sub {  \$_[0]  } },
    'prefix:+'  => { sub => sub {  +$_[0]  } },
    'prefix:-'  => { sub => sub {  -$_[0]  } },
    'prefix:$'  => { sub => sub { ${$_[0]} } },
    'prefix:@'  => { sub => sub { @{$_[0]} } },
    'prefix:%'  => { sub => sub { %{$_[0]} } },
    'prefix:&'  => { sub => sub { &{$_[0]} } },
    'prefix:*'  => { sub => sub { *{$_[0]} } },

    # unary postfix
    'postfix:++' => { sub => sub { $_[0]++ } },
    'postfix:--' => { sub => sub { $_[0]-- } },

    # circumfix
    'circumfix:()'  => { sub => sub {  ($_[0]) } },
    'circumfix:[]'  => { sub => sub {  [$_[0]] } },
    'circumfix:{}'  => { sub => sub {  {$_[0]} } },
    'circumfix:${}' => { sub => sub { ${$_[0]} } },
    'circumfix:@{}' => { sub => sub { @{$_[0]} } },
    'circumfix:%{}' => { sub => sub { %{$_[0]} } },
    'circumfix:&{}' => { sub => sub { &{$_[0]} } },
    'circumfix:*{}' => { sub => sub { *{$_[0]} } },

    # postcircumfix
    'postcircumfix:[]'   => { sub => sub { $_[0]->[$_[1]] }, res => [undef] },
    'postcircumfix:{}'   => { sub => sub { $_[0]->{$_[1]} }, res => [undef] },
    'postcircumfix:->[]' => { sub => sub { $_[0]->[$_[1]] }, res => [undef] },
    'postcircumfix:->{}' => { sub => sub { $_[0]->{$_[1]} }, res => [undef] },
);

# Perl 5.10 operators
if ($] >= 5.010) {
    $ops{'infix:~~'} = { sub => eval 'sub { $_[0] ~~ $_[1] }', res => [1, 1], chain => 1 };
    $ops{'infix://'} = { sub => eval 'sub { $_[0] // $_[1] }', res => [0] };
}

sub reduce {
    my ($op, $list, %args) = @_;
    my $type;
    ($op, $type) = _get_op_info($op);

    return unless $op;
    return if $type ne 'infix';

    my @list = ref $list eq 'ARRAY' ? @$list :
               defined $list        ? $list  :
                                      ()     ;

    # return default for zero args
    return $ops{$op}{res}[0]
        unless @list;

    # return default for one arg if defined, otherwise return the arg itself
    return exists $ops{$op}{res}[1] ? $ops{$op}{res}[1] : $list[0]
        if @list == 1;

    if ( $ops{$op}{right} ) {
        @list = reverse @list;
    }

    my $result   = shift @list;
    my $bool     = 1;
    my @triangle = $ops{$op}{chain} ? $bool : $result;

    my $apply = sub {
        my ($a, $b) = @_;
        return applyop( $op, $ops{$op}{right} ? ($b, $a) : ($a, $b) );
    };

    while (@list) {
        my $next = shift @list;

        if ( $ops{$op}{chain} ) {
            $bool = $bool && $apply->($result, $next);
            $result = $next;
            push @triangle, $bool if $args{triangle};
        }
        else {
            $result = $apply->($result, $next);
            push @triangle, $result if $args{triangle};
        }
    }

    return @triangle if $args{triangle};
    return $bool     if $ops{$op}{chain};
    return $result;
}

sub zip   { zipwith(   ',', @_ ) }
sub cross { crosswith( ',', @_ ) }

sub zipwith {
    my ($op, $lhs, $rhs) = @_;
    my ($a, $b, @results);

    $lhs = [$lhs] if ref $lhs ne 'ARRAY';
    $rhs = [$rhs] if ref $rhs ne 'ARRAY';

    while (@$lhs && @$rhs) {
        $a = shift @$lhs;
        $b = shift @$rhs;
        push @results, applyop($op, $a, $b);
    }

    return @results;
}

sub crosswith {
    my ($op, $lhs, $rhs) = @_;
    my ($a, $b, @results);

    $lhs = [$lhs] if ref $lhs ne 'ARRAY';
    $rhs = [$rhs] if ref $rhs ne 'ARRAY';

    for my $a (@$lhs) {
        for my $b (@$rhs) {
            push @results, applyop($op, $a, $b);
        }
    }

    return @results;
}

sub hyper {
    my ($op, $lhs, $rhs, %args) = @_;

    if (@_ == 2) {
        return map {
            ref eq 'ARRAY' ? [ hyper($op, $_) ] :
            ref eq 'HASH'  ? { hyper($op, $_) } :
                             applyop($op, $_)
        } @$lhs if ref $lhs eq 'ARRAY';

        return map {
            $_ => ref eq 'ARRAY' ? [ hyper($op, $_) ] :
                  ref eq 'HASH'  ? { hyper($op, $_) } :
                                   applyop($op, $lhs->{$_})
        } keys %$lhs if ref $lhs eq 'HASH';

        return applyop($op, $$lhs) if ref $lhs eq 'SCALAR';
        return applyop($op, $lhs);
    }

    my $dwim_left  = $args{dwim_left}  || $args{dwim};
    my $dwim_right = $args{dwim_right} || $args{dwim};

    if (ref $lhs eq 'HASH' && ref $rhs eq 'HASH') {
        my %results;
        my @keys = do {
            if ($dwim_left && $dwim_right) { # intersection
                grep { exists $rhs->{$_} } keys %$lhs;
            }
            elsif ($dwim_left) {
                keys %$rhs;
            }
            elsif ($dwim_right) {
                keys %$lhs;
            }
            else { # union
                uniq keys %$lhs, keys %$rhs;
            }
        };

        for my $key (@keys) {
            $results{$key} = do {
                if ( exists $lhs->{$key} && exists $rhs->{$key} ) {
                    applyop( $op, $lhs->{$key}, $rhs->{$key} );
                }
                else {
                    exists $ops{$op}{res}[1] ? $ops{$op}{res}[1] :
                    exists $lhs->{$key}      ? $lhs->{$key}      :
                                               $rhs->{$key}      ;
                }
            };
        }

        return %results;
    }
    elsif (ref $lhs eq 'HASH') {
        die "Sorry, structures on both sides of non-dwimmy hyper() are not of same shape:\n"
            . "    left:  HASH\n"
            . "    right: " . ref($rhs) . "\n"
            unless $dwim_right;

        return map { $_ => applyop( $op, $lhs->{$_}, $rhs ) } keys %$lhs;
    }
    elsif (ref $rhs eq 'HASH') {
        die "Sorry, structures on both sides of non-dwimmy hyper() are not of same shape:\n"
            . "    left: " . ref($rhs) . "\n"
            . "    right:  HASH\n"
            unless $dwim_left;

        return map { $_ => applyop( $op, $lhs, $rhs->{$_} ) } keys %$rhs;
    }

    my $length;
    $lhs = [$lhs] if ref $lhs ne 'ARRAY';
    $rhs = [$rhs] if ref $rhs ne 'ARRAY';

    if (!$dwim_left && !$dwim_right) {
        die "Sorry, arrayrefs passed to non-dwimmy hyper() are not of same length:\n"
            . "    left:  " . @$lhs . " elements\n"
            . "    right: " . @$rhs . " elements\n"
            if @$lhs != @$rhs;

        $length = @$lhs;
    }
    elsif (!$dwim_left) {
        $length = @$lhs;
    }
    elsif (!$dwim_right) {
        $length = @$rhs;
    }
    else {
        $length = @$lhs > @$rhs ? @$lhs : @$rhs;
    }

    my @results;
    my $lhs_index = 0;
    my $rhs_index = 0;
    for (1 .. $length) {
        $lhs_index = 0 if $dwim_left  && $lhs_index > $#{$lhs};
        $rhs_index = 0 if $dwim_right && $rhs_index > $#{$rhs};
        push @results, applyop($op, $lhs->[$lhs_index], $rhs->[$rhs_index]);
    }
    continue {
        $lhs_index++;
        $rhs_index++;
    }

    return @results;
}

sub applyop {
    my ($op) = @_;
    my $type;
    ($op, $type) = _get_op_info($op);

    return unless $op;
    return $ops{$op}{sub}->( @_[1, 2] )
        if $type eq 'infix'
        || $type eq 'postcircumfix';
    return $ops{$op}{sub}->( $_[1] );
}

sub reverseop {
    my ($op) = @_;

    return applyop( $op, $_[1]    ) if $op =~ m{^ (?: pre | post ) fix : }x;
    return applyop( $op, @_[1, 2] );
}

sub _get_op_info {
    my ($op) = @_;
    my ($type) = $op =~ m{^ (\w+) : }x;

    if (!$type) {
        $type = "infix";
        $op   = "infix:$op";
    }

    return unless exists $ops{$op};
    return $op, $type;
}

1;

__END__