File Coverage

blib/lib/Iterator/Flex/Base.pm

Criterion	Covered	Total	%
statement	293	312	93.9
branch	55	74	74.3
condition	29	44	65.9
subroutine	49	52	94.2
pod	16	21	76.1
total	442	503	87.8

package Iterator::Flex::Base;

# ABSTRACT: Iterator object

use v5.28;
use strict;
use warnings;

use experimental qw( signatures postderef declared_refs );

our $VERSION = '0.34';

use Ref::Util;
use Scalar::Util;
use List::Util;
use Role::Tiny       ();
use Role::Tiny::With ();
use Module::Runtime  ();

use Iterator::Flex::Utils qw (
  :default
  :ExhaustionActions
  :GeneralParameters
  :RegistryIndices
  :IterAttrs
  :IterStates
  :InterfaceParameters
  :SignalParameters
  load_role
  throw_failure
);

use namespace::clean;

use overload
  '<>'     => sub ( $self, $, $ ) { &{$self}() },
  fallback => 0,
  bool     => sub { 1 },

  # these are required for the perldb to not barf
  # see https://github.com/Perl/perl5/issues/23486
  eq    => sub { 0 },
  q{""} => sub { q{} },
  ;

# We separate constructor parameters into two categories:
#
#  1. those that are used to construct the iterator
#  2. those that specify what happens when the iterator signals exhaustion
#
#  Category #2 may be expanded. Category #2 parameters are *not* passed
#  to the iterator class construct* routines


sub new ( $class, $state = undef, $general = {} ) {
    return $class->new_from_state( $state, $general );
}

sub new_from_state ( $class, $state, $general ) {
    return $class->new_from_attrs( $class->construct( $state ), $general );
}

sub new_from_attrs ( $class, $in_ipar = {}, $in_gpar = {} ) {    ## no critic (ExcessComplexity)

    my %ipar = $in_ipar->%*;
    my %gpar = $in_gpar->%*;

    $class->_validate_interface_pars( \%ipar );
    $class->_validate_signal_pars( \%gpar );

    my @roles = ( delete( $ipar{ +_ROLES } ) // [] )->@*;

    $gpar{ +ERROR } //= [THROW];
    $gpar{ +ERROR } = [ $gpar{ +ERROR } ]
      unless Ref::Util::is_arrayref( $gpar{ +ERROR } );

    if ( $gpar{ +ERROR }[0] eq THROW ) {
        push @roles, 'Error::Throw';
    }
    else {
        throw_failure( q{unknown specification of iterator error signaling behavior:}, $gpar{ +ERROR }[0] );
    }

    my $exhaustion_action = $gpar{ +EXHAUSTION } // [ ( +RETURN ) => undef ];

    my @exhaustion_action
      = Ref::Util::is_arrayref( $exhaustion_action )
      ? ( $exhaustion_action->@* )
      : ( $exhaustion_action );

    $gpar{ +EXHAUSTION } = \@exhaustion_action;

    if ( $exhaustion_action[0] eq RETURN ) {
        push @roles, 'Exhaustion::Return';
    }
    elsif ( $exhaustion_action[0] eq THROW ) {

        push @roles,
          @exhaustion_action > 1 && $exhaustion_action[1] eq PASSTHROUGH
          ? 'Exhaustion::PassthroughThrow'
          : 'Exhaustion::Throw';
    }
    else {
        throw_failure( parameter => "unknown exhaustion action: $exhaustion_action[0]" );
    }

    if ( defined( my $par = $ipar{ +METHODS } ) ) {

        require Iterator::Flex::Method;

        throw_failure( parameter => q{value for methods parameter must be a hash reference} )
          unless Ref::Util::is_hashref( $par );

        for my $name ( keys $par->%* ) {

            my $code = $par->{$name};

            throw_failure( parameter => "value for 'methods' parameter key '$name' must be a code reference" )
              unless Ref::Util::is_coderef( $code );

            # create role for the method
            my $role = eval { Iterator::Flex::Method::Maker( $name, name => $name ) };

            if ( $@ ne q{} ) {
                my $error = $@;
                die $error
                  unless Ref::Util::is_blessed_ref( $error )
                  && $error->isa( 'Iterator::Flex::Failure::RoleExists' );
                $role = $error->payload;
            }

            push @roles, q{+} . $role;    # need '+', as these are fully qualified role module names.
        }
    }

    @roles = map { load_role( $_, $class->_role_namespaces ) } @roles;
    $class = Role::Tiny->create_class_with_roles( $class, @roles );

    unless ( $class->can( '_construct_next' ) ) {
        throw_failure(
            class => "Constructed class '$class' does not provide the required _construct_next method\n" );
    }

    unless ( $class->does( 'Iterator::Flex::Role::State' ) ) {
        throw_failure( class => "Constructed class '$class' does not provide a State role\n" );
    }

    $ipar{ +_NAME } //= $class;

    my $self = bless $class->_construct_next( \%ipar, \%gpar ), $class;

    throw_failure(
        parameter => q{attempt to register an iterator subroutine which has already been registered.} )
      if exists $REGISTRY{ refaddr $self };

    my $regentry = $REGISTRY{ refaddr $self } = [];

    # convert to arrays. some of the parameter values are weak
    # references so make sure we don't unweaken them
    my @ipar;
    for my $key ( keys %ipar ) {
        $ipar[ $RegIterationIndexMap{$key} ] = $ipar{$key};
        Scalar::Util::weaken $ipar[ $RegIterationIndexMap{$key} ]
          if Ref::Util::is_ref( $ipar{$key} )
          && Scalar::Util::isweak( $ipar{$key} );
    }
    my @gpar;
    for my $key ( keys %gpar ) {
        $gpar[ $RegGeneralParameterIndexMap{$key} ] = $gpar{$key};
        Scalar::Util::weaken $gpar[ $RegGeneralParameterIndexMap{$key} ]
          if Ref::Util::is_ref( $gpar{$key} )
          && Scalar::Util::isweak( $gpar{$key} );
    }

    $regentry->[REG_ITERATOR] = \@ipar;
    $regentry->[REG_GENERAL]  = \@gpar;

    $self->_clear_state;

    return $self;
}

sub _validate_interface_pars ( $class, $pars ) {
    state %InterfaceParameters = {}->%{ +INTERFACE_PARAMETER_VALUES };

    my @bad = grep { !exists $InterfaceParameters{$_} } keys $pars->%*;

    throw_failure( parameter => "unknown interface parameters: @{[ join ', ', @bad ]}" )
      if @bad;

    throw_failure( parameter => "@{[ _ROLES ]}  must be an arrayref" )
      if defined $pars->{_ROLES} && !Ref::Util::is_arrayref( $pars->{ +_ROLES } );

    if ( defined( my $par = $pars->{ +_DEPENDS } ) ) {
        $pars->{ +_DEPENDS } = $par = [$par] unless Ref::Util::is_arrayref( $par );
        throw_failure( parameter => "dependency #$_ is not an iterator object" )
          unless List::Util::all { $class->_is_iterator( $_ ) } $par->@*;
    }

    return;
}

sub _validate_signal_pars ( $class, $pars ) {
    state %SignalParameters = {}->%{ +SIGNAL_PARAMETER_VALUES };
    my @bad = grep { !exists $SignalParameters{$_} } keys $pars->%*;

    throw_failure( parameter => "unknown signal parameters: @{[ join ', ', @bad ]}" )
      if @bad;
}


sub DESTROY ( $self ) {

    if ( defined $self ) {
        delete $REGISTRY{ refaddr $self };
    }
}

sub _name ( $self ) {
    $REGISTRY{ refaddr $self }[REG_ITERATOR][REG_ITER__NAME];
}






















# TODO: this is too restrictive. It should allow simple coderefs, or
# things with a next or __next__.

sub _is_iterator ( $, $obj ) {
    return Ref::Util::is_blessed_ref( $obj ) && $obj->isa( __PACKAGE__ );
}













sub __iter__ ( $self ) {
    return $REGISTRY{ refaddr $self }[REG_ITERATOR][REG_ITER_NEXT];
}













sub may ( $self, $meth ) {

    my \@attributes = $REGISTRY{ refaddr $self }[REG_ITERATOR];
    my $may         = $attributes[REG_ITER_MAY_METHOD] //= {};

    return $may->{"_may_$meth"}
      //= defined $attributes[REG_ITER__DEPENDS]
      ? !List::Util::first { !$_->may( $meth ) } $attributes[REG_ITER__DEPENDS]->@*
      : defined $attributes[ $RegIterationIndexMap{$meth} ];
}
















sub _namespaces {
    return 'Iterator::Flex';
}
















sub _role_namespaces {
    return 'Iterator::Flex::Role';
}

















sub _add_roles ( $class, @roles ) {
    Role::Tiny->apply_roles_to_package( $class,
        map { load_role( $_, $class->_role_namespaces ) } @roles );
}

sub _apply_method_to_depends ( $self, $meth ) {

    if ( defined( my $depends = $REGISTRY{ refaddr $self }[REG_ITERATOR][REG_ITER__DEPENDS] ) ) {
        # first check if dependencies have method
        my $cant = List::Util::first { !$_->can( $meth ) } $depends->@*;
        throw_failure( Unsupported => "dependency: @{[ $cant->_name ]} does not have a '$meth' method" )
          if $cant;

        # now apply the method
        $_->$meth foreach $depends->@*;
    }
}









sub is_exhausted ( $self ) {
    $self->get_state == IterState_EXHAUSTED;
}














sub set_exhausted ( $self ) {
    $self->set_state( IterState_EXHAUSTED );
}














sub _clear_state ( $self ) {
    $self->set_state( IterState_CLEAR );
}









sub is_error ( $self ) {
    $self->get_state == IterState_ERROR;
}














sub set_error ( $self ) {
    $self->set_state( IterState_ERROR );
}









sub throws_on_exhaustion( $self ) {
    return $REGISTRY{ refaddr $self }[REG_GENERAL][REG_GP_EXHAUSTION][0] eq THROW;

}









sub returns_on_exhaustion( $self ) {
    return $REGISTRY{ refaddr $self }[REG_GENERAL][REG_GP_EXHAUSTION][0] eq RETURN;

}









sub buffer ( $self, $n = 0, $pars = {} ) {
    require Iterator::Flex::Buffer;
    Iterator::Flex::Buffer->new( $self, $n, $pars );
}










sub cache ( $self, $pars = {} ) {
    require Iterator::Flex::Cache;
    Iterator::Flex::Cache->new( $self, $pars );
}

sub icache;
*icache = \&cache;












sub cat ( $self, @args ) {
    require Iterator::Flex::Cat;
    Iterator::Flex::Cat->new( $self, @args );
}

sub chain;
*chain = \&cat;












sub chunk ( $self, $pars = {} ) {
    require Iterator::Flex::Chunk;
    Iterator::Flex::Chunk->new( $self, $pars );
}

sub ichunk;
*ichunk = \&chunk;

sub batch;
*batch = \&chunk;














sub drain ( $self, $n = undef ) {

    throw_failure( parameter => '$n is not a positive integer' )
      if defined $n && !( Scalar::Util::looks_like_number( $n ) && int( $n ) == $n && $n > 0 );

    my @values;

    eval {
        if ( $n ) {
            while ( $n-- ) {
                push @values, $self->next;
                if ( $self->is_exhausted ) {
                    pop @values;
                    last;
                }
            }
        }
        else {
            while ( 1 ) {
                push @values, $self->next;
                if ( $self->is_exhausted ) {
                    pop @values;
                    last;
                }
            }
        }
        1;
    } or do {
        die $@
          unless Ref::Util::is_blessed_ref( $@ )
          && $@->isa( 'Iterator::Flex::Failure::Exhausted' );
    };

    return \@values;
}









sub flatten ( $self, $pars = {} ) {
    require Iterator::Flex::Flatten;
    return Iterator::Flex::Flatten->new( $self, $pars );
}

sub iflatten;
*iflatten = \*flatten;










sub foreach ( $self, $code ) {    ## no critic (BuiltinHomonyms)

    if ( $self->throws_on_exhaustion ) {
        eval {
            local $_;    ## no critic (InitializationForLocalVars)
            while ( 1 ) { $_ = $self->(); $code->() }
            1;
        } or do {
            die $@
              unless Ref::Util::is_blessed_ref( $@ )
              && $@->isa( 'Iterator::Flex::Failure::Exhausted' );
        };
    }
    elsif ( $self->returns_on_exhaustion ) {

        # optimize for when sentinel is the undefined value
        if ( !defined $self->sentinel ) {
            local $_;    ## no critic (InitializationForLocalVars)
            $code->() while defined( $_ = $self->() );
        }

        # yeah, this is too slow.  should adapt the logic in Wrap::Return.
        else {
            local $_;                          ## no critic (InitializationForLocalVars)
            $_ = $self->();
            until ( $self->is_exhausted ) {    ## no critic (UntilBlock)
                $code->();
                $_ = $self->();
            }
        }
    }
}










sub gather ( $self, $code, $pars = {} ) {
    require Iterator::Flex::Gather;
    Iterator::Flex::Gather->new( $code, $self, $pars );
}

sub igather;
*igather = \&gather;









sub grep ( $self, $code, $pars = {} ) {    ## no critic (BuiltinHomonyms)

    require Iterator::Flex::Grep;
    Iterator::Flex::Grep->new( $code, $self, $pars );
}

sub igrep;
*igrep = \&grep;









sub map ( $self, $code, $pars = {} ) {    ## no critic (BuiltinHomonyms)

    require Iterator::Flex::Map;
    Iterator::Flex::Map->new( $code, $self, $pars );
}

sub imap;
*imap = \↦









sub take ( $self, $n, $pars = {} ) {
    require Iterator::Flex::Take;
    Iterator::Flex::Take->new( $self, $n, $pars );
}

1;

#
# This file is part of Iterator-Flex
#
# This software is Copyright (c) 2018 by Smithsonian Astrophysical Observatory.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 3, June 2007
#

__END__