view release on metacpan or  search on metacpan

lib/Iterator/Flex/Factory.pm  view on Meta::CPAN

package Iterator::Flex::Factory;

# ABSTRACT: Create on-the-fly Iterator::Flex classes/objects

use v5.28;
use strict;
use warnings;

use experimental qw( signatures declared_refs refaliasing);

our $VERSION = '0.34';

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

use Exporter 'import';

our @EXPORT_OK = qw( to_iterator construct_from_iterable construct_from_attr );

use Iterator::Flex::Base;
use Iterator::Flex::Utils qw[
  :ExhaustionActions
  :default
  :RegistryIndices
  :SignalParameters
  :IterAttrs
  parse_pars
  throw_failure
  can_meth
];












sub to_iterator ( $iterable = undef, $pars = {} ) {
    return defined $iterable
      ? construct_from_iterable( $iterable, $pars )
      : construct( {
          ( +NEXT ) => sub { },
      } );
}



############################################################################












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

    throw_failure( parameter => q{'iterator parameters' parameter must be a hashref} )
      unless Ref::Util::is_hashref( $in_ipar );

    throw_failure( parameter => q{'general parameters' parameter must be a hashref} )
      unless Ref::Util::is_hashref( $in_gpar );

    my %ipar = $in_ipar->%*;
    my %ipar_k;
    @ipar_k{ keys %ipar } = ();
    my %gpar = $in_gpar->%*;
    my %gpar_k;
    @gpar_k{ keys %gpar } = ();

    my $par;
    my @roles;

    my $class = $ipar{ +CLASS } // 'Iterator::Flex::Base';
    delete $ipar_k{ +CLASS };

    throw_failure( parameter => q{'class' parameter must be a string} )
      if Ref::Util::is_ref( $class );

    throw_failure( parameter => "can't load class $class" )
      if $class ne 'Iterator::Flex::Base'
      && !Module::Runtime::require_module( $class );

    delete $ipar_k{ +_NAME };
    throw_failure( parameter => "'@{[ _NAME ]}' parameter value must be a string\n" )
      if defined( $par = $ipar{ +_NAME } ) && Ref::Util::is_ref( $par );

    push @roles, 'State::Registry';

    delete $gpar_k{ +INPUT_EXHAUSTION };
    my $input_exhaustion = $gpar{ +INPUT_EXHAUSTION } // [ ( +RETURN ) => undef ];

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

    delete $gpar_k{ +EXHAUSTION };
    my $has_output_exhaustion_policy = defined $gpar{ +EXHAUSTION };

    if ( $input_exhaustion[0] eq RETURN ) {
        push @roles, 'Exhaustion::ImportedReturn', 'Wrap::Return';
        push $input_exhaustion->@*, undef if @input_exhaustion == 1;
        $gpar{ +INPUT_EXHAUSTION } = \@input_exhaustion;
        $gpar{ +EXHAUSTION }       = $gpar{ +INPUT_EXHAUSTION }
          unless $has_output_exhaustion_policy;
    }

    elsif ( $input_exhaustion[0] eq THROW ) {
        push @roles, 'Exhaustion::ImportedThrow', 'Wrap::Throw';
        $gpar{ +INPUT_EXHAUSTION } = \@input_exhaustion;
        $gpar{ +EXHAUSTION }       = [ ( +THROW ) => PASSTHROUGH ]
          unless $has_output_exhaustion_policy;
    }

    throw_failure( parameter => q{missing or undefined 'next' parameter} )
      if !defined( $ipar{ +NEXT } );

    for my $method ( NEXT, REWIND, RESET, PREV, CURRENT ) {

        delete $ipar_k{$method};
        next unless defined( my $code = $ipar{$method} );

        throw_failure( parameter => "'$method' parameter value must be a code reference\n" )
          unless Ref::Util::is_coderef( $code );

        # if $class can't perform the required method, add a role
        # which can.
        if ( $method eq NEXT ) {
            # next is always a closure, but the caller may want to
            # keep track of $self
            push @roles, defined $ipar{ +_SELF } ? 'Next::ClosedSelf' : 'Next::Closure';
            delete $ipar_k{ +_SELF };
        }
        else {
            my $impl = $class->can( $method ) ? 'Method' : 'Closure';
            push @roles, ucfirst( $method ) . q{::} . $impl;
        }
    }

    # these are dealt with in the iterator constructor.
    delete @ipar_k{ METHODS, FREEZE };
    delete $gpar_k{ +ERROR };

    if ( !!%ipar_k || !!%gpar_k ) {

        throw_failure( parameter => "unknown iterator parameters: @{[ join( ', ', keys %ipar_k ) ]}" )
          if %ipar_k;
        throw_failure( parameter => "unknown iterator parameters: @{[ join( ', ', keys %gpar_k ) ]}" )
          if %gpar_k;
    }

    $ipar{_roles} = \@roles;

    return $class->new_from_attrs( \%ipar, \%gpar );
}


































sub construct_from_iterable ( $obj, $pars = {} ) {

    my ( $mpars, $ipars, $spars ) = parse_pars( $pars );

    my $action_on_failure = delete $mpars->{action_on_failure} // THROW;

    throw_failure( parameter => "illegal value for action_on_failure: $action_on_failure" )
      if $action_on_failure ne THROW && $action_on_failure ne RETURN;

    throw_failure( parameter =>
          "unknown parameters passed to construct_from_iterable: @{[ join ', ', keys $mpars->%* ]}" )
      if $mpars->%*;

    ## no critic ( CascadingIfElse )
    if ( Ref::Util::is_blessed_ref( $obj ) ) {

        return construct_from_iterator_flex( $obj, $ipars, $spars )
          if $obj->isa( 'Iterator::Flex::Base' );

        return construct_from_object( $obj, $ipars, $spars );
    }

    elsif ( Ref::Util::is_arrayref( $obj ) ) {
        throw_failure(
            parameter => "unknown parameters passed to construct_from_iterable: @{[ join ', ', $ipars->%* ]}" )
          if $ipars->%*;
        require Iterator::Flex::Array;
        return Iterator::Flex::Array->new( $obj, $spars );
    }

    elsif ( Ref::Util::is_coderef( $obj ) ) {
        return construct( { $ipars->%*, next => $obj }, $spars );
    }

    elsif ( Ref::Util::is_globref( $obj ) ) {
        return construct( {
                $ipars->%*, next => sub { scalar <$obj> },
            },
            $spars,
        );
    }

    return undef
      if $action_on_failure eq RETURN;

    throw_failure(
        parameter => sprintf q{'%s' object is not iterable},
        ( ref( $obj ) || 'SCALAR' ) );
}























sub construct_from_object ( $obj, $ipar, $gpar ) {

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

    $gpar{ +INPUT_EXHAUSTION } //= [ ( +RETURN ) => undef ];

    if ( !exists $ipar{ +NEXT } ) {
        my $code;
        ## no critic( CascadingIfElse )
        if ( $code = can_meth( $obj, 'iter' ) ) {
            $ipar{ +NEXT } = $code->( $obj );
        }
        elsif ( $code = can_meth( $obj, 'next' )
            || overload::Method( $obj, '<>', undef, undef ) )
        {
            $ipar{ +NEXT } = sub { $code->( $obj ) };
        }

        elsif ( $code = overload::Method( $obj, '&{}', undef, undef ) ) {
            $ipar{ +NEXT } = $code->( $obj );
        }

        elsif ( $code = overload::Method( $obj, '@{}', undef, undef ) ) {
            require Iterator::Flex::Array;
            return Iterator::Flex::Array->new( $code->( $obj ), \%gpar );
        }

    }

    for my $method ( grep { !exists $ipar{$_} } PREV, CURRENT ) {
        my $code = can_meth( $obj, $method );
        $ipar{$method} = sub { $code->( $obj ) }
          if $code;
    }

    return construct( \%ipar, \%gpar );
}


# create a proxy object for an Iterator::Flex object.  This is only
# required if an adaptor needs a different exhaustion signal than is
# provided by the object.

# Currently, proxy objects are not treated specially when de-serializing
# (e.g., they'll be run through to_iterator), but it *should* be a no-op.


sub construct_from_iterator_flex ( $obj, $, $gpar ) {

    my \@registry
      = exists $REGISTRY{ refaddr $obj }
      ? $REGISTRY{ refaddr $obj }[REG_GENERAL]
      : throw_failure( internal => q{non-registered Iterator::Flex iterator} );


    # if caller didn't specify an exhaustion, set it to return => undef
    my @want = do {
        my $exhaustion = $gpar->{ +EXHAUSTION } // [ ( +RETURN ) => undef ];
        Ref::Util::is_arrayref( $exhaustion )
          ? ( $exhaustion->@* )
          : ( $exhaustion );
    };


    # multiple different output exhaustion roles may have been
    # applied, so the object may claim to support both roles,
    # Exhaustion::Throw and Exhaustion::Return, although only the
    # latest one applied will work.  So, use what's in the registry to
    # figure out what it actually does.

    my \@have = $registry[REG_GP_EXHAUSTION] // throw_failure(
        internal => q{registered Iterator::Flex iterator doesn't have a registered exhaustion} );

    # reuse the object if the requested and existing exhaustion signals are the same.
    return $obj
      if $want[0] eq $have[0]
      && ( ( defined $want[1] && defined $have[1] && $want[1] eq $have[1] )
        || ( !defined $want[1] && !defined $have[1] ) );

    # now we need a proxy object.
    my %gpars = (
        exhaustion       => [@want],
        input_exhaustion => [@have],
    );

    my %ipars;
    for my $method ( NEXT, PREV, CURRENT, REWIND, RESET, FREEZE ) {
        next unless defined( my $code = can_meth( $obj, $method ) );
        $ipars{$method} = sub { $code->( $obj ) };
    }

    return construct( \%ipars, \%gpars );
}

sub construct_from_attr ( $in_ipar = {}, $in_gpar = {} ) {
    my %gpar = $in_gpar->%*;

    # this indicates that there should be no wrapping of 'next'
    $gpar{ +INPUT_EXHAUSTION } = PASSTHROUGH;
    construct( $in_ipar, \%gpar );
}

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__

=pod

=for :stopwords Diab Jerius Smithsonian Astrophysical Observatory