File Coverage

blib/lib/List/Objects/WithUtils/Array/Junction.pm

Criterion	Covered	Total	%
statement	157	162	96.9
branch	98	100	98.0
condition			n/a
subroutine	36	38	94.7
pod			n/a
total	291	300	97.0

package List::Objects::WithUtils::Array::Junction;
$List::Objects::WithUtils::Array::Junction::VERSION = '2.027002';
## no critic

{ package
    List::Objects::WithUtils::Array::Junction::Base;
  use strictures 2;
  use parent 'List::Objects::WithUtils::Array';
  use overload
    '=='   => 'num_eq',
    '!='   => 'num_ne',
    '>='   => 'num_ge',
    '>'    => 'num_gt',
    '<='   => 'num_le',
    '<'    => 'num_lt',
    'eq'   => 'str_eq',
    'ne'   => 'str_ne',
    'ge'   => 'str_ge',
    'gt'   => 'str_gt',
    'le'   => 'str_le',
    'lt'   => 'str_lt',
    'bool' => 'bool',
    '""'   => sub { shift },
  ;
}
{ package
    List::Objects::WithUtils::Array::Junction::All;
  use strict; use warnings;
  our @ISA = 'List::Objects::WithUtils::Array::Junction::Base';

  sub num_eq {
    return regex_eq(@_) if ref $_[1] eq 'Regexp';
    for (@{ $_[0] })
      { return unless $_ == $_[1] }
    1
  }

  sub num_ne {
    return regex_ne(@_) if ref $_[1] eq 'Regexp';
    for (@{ $_[0] })
      { return unless $_ != $_[1] }
    1
  }

  sub num_ge {
    return num_le( @_[0, 1] ) if $_[2];
    for (@{ $_[0] })
      { return unless $_ >= $_[1] }
    1
  }

  sub num_gt {
    return num_lt( @_[0, 1] ) if $_[2];
    for (@{ $_[0] })
      { return unless $_ > $_[1] }
    1
  }

  sub num_le {
    return num_ge( @_[0, 1] ) if $_[2];
    for (@{ $_[0] })
      { return unless $_ <= $_[1] }
    1
  }

  sub num_lt {
    return num_gt( @_[0, 1] ) if $_[2];
    for (@{ $_[0] })
      { return unless $_ < $_[1] }
    1
  }

  sub str_eq {
    for (@{ $_[0] })
      { return unless $_ eq $_[1] }
    1
  }

  sub str_ne {
    for (@{ $_[0] })
      { return unless $_ ne $_[1] }
    1
  }

  sub str_ge {
    return str_le( @_[0, 1] ) if $_[2];
    for (@{ $_[0] })
      { return unless $_ ge $_[1] }
    1
  }

  sub str_gt {
    return str_lt( @_[0, 1] ) if $_[2];
    for (@{ $_[0] })
      { return unless $_ gt $_[1] }
    1
  }

  sub str_le {
    return str_ge( @_[0, 1] ) if $_[2];
    for (@{ $_[0] })
      { return unless $_ le $_[1] }
    1
  }

  sub str_lt {
    return str_gt( @_[0, 1] ) if $_[2];
    for (@{ $_[0] })
      { return unless $_ lt $_[1] }
    1
  }

  sub regex_eq {
    for (@{ $_[0] })
      { return unless $_ =~ $_[1] }
    1
  }

  sub regex_ne {
    for (@{ $_[0] })
      { return unless $_ !~ $_[1] }
    1
  }

  sub bool {
    for (@{ $_[0] })
      { return unless $_ }
    1
  }

}

{ package
    List::Objects::WithUtils::Array::Junction::Any;
  use strict; use warnings;
  our @ISA = 'List::Objects::WithUtils::Array::Junction::Base';

  sub num_eq {
    return regex_eq(@_) if ref $_[1] eq 'Regexp';
    for (@{ $_[0] })
      { return 1 if $_ == $_[1] }
    ()
  }

  sub num_ne {
    return regex_eq(@_) if ref $_[1] eq 'Regexp';
    for (@{ $_[0] })
      { return 1 if $_ != $_[1] }
    ()
  }

  sub num_ge {
    return num_le( @_[0, 1] ) if $_[2];
    for (@{ $_[0] })
      { return 1 if $_ >= $_[1] }
    ()
  }

  sub num_gt {
    return num_lt( @_[0, 1] ) if $_[2];
    for (@{ $_[0] })
      { return 1 if $_ > $_[1] }
    ()
  }

  sub num_le {
    return num_ge( @_[0, 1] ) if $_[2];
    for (@{ $_[0] })
      { return 1 if $_ <= $_[1] }
    ()
  }

  sub num_lt {
    return num_gt( @_[0, 1] ) if $_[2];
    for (@{ $_[0] })
      { return 1 if $_ < $_[1] }
    ()
  }

  sub str_eq {
    for (@{ $_[0] })
      { return 1 if $_ eq $_[1] }
    ()
  }

  sub str_ne {
    for (@{ $_[0] })
      { return 1 if $_ ne $_[1] }
    ()
  }

  sub str_ge {
    return str_le( @_[0, 1] ) if $_[2];
    for (@{ $_[0] })
      { return 1 if $_ ge $_[1] }
    ()
  }

  sub str_gt {
    return str_lt( @_[0, 1] ) if $_[2];
    for (@{ $_[0] })
      { return 1 if $_ gt $_[1] }
    ()
  }

  sub str_le {
    return str_ge( @_[0, 1] ) if $_[2];
    for (@{ $_[0] })
      { return 1 if $_ le $_[1] }
    ()
  }

  sub str_lt {
    return str_gt( @_[0, 1] ) if $_[2];
    for (@{ $_[0] })
      { return 1 if $_ lt $_[1] }
    ()
  }

  sub regex_eq {
    for (@{ $_[0] })
      { return 1 if $_ =~ $_[1] }
    ()
  }

  sub regex_ne {
    for (@{ $_[0] })
      { return 1 if $_ !~ $_[1] }
    ()
  }

  sub bool {
    for (@{ $_[0] })
      { return 1 if $_ }
    ()
  }
}

1;

=pod

=for Pod::Coverage new

=head1 NAME

List::Objects::WithUtils::Array::Junction - Lightweight junction classes

=head1 SYNOPSIS

  # See List::Objects::WithUtils::Role::Array::WithJunctions

=head1 DESCRIPTION

These are light-weight junction objects covering most of the functionality
provided by L. They provide the objects created by
the C and C methods defined by
L.

Only the junction types used by L ('any' and 'all')
are implemented; nothing is exported. The C<~~> smart-match operator is not
supported. See L if you were looking for a
stand-alone implementation with more features.

The junction objects produced are subclasses of
L.

See L for usage details.

=head2 Motivation

My original goal was to get L out of the
L dependency tree; that one came along with
L.

L would have done that for me. Unfortunately, that comes with
some unresolved RT bugs right now that are reasonably annoying (especially
warnings under perl-5.18.x).

=head1 AUTHOR

This code is originally derived from L by way of
L; the original author is Carl Franks, based on the
Perl6 design documentation.

Adapted to L by Jon Portnoy

=cut