File Coverage

blib/lib/IPC/PrettyPipe.pm

Criterion	Covered	Total	%
statement	172	182	94.5
branch	47	74	63.5
condition	15	20	75.0
subroutine	37	38	97.3
pod	9	11	81.8
total	280	325	86.1

package IPC::PrettyPipe;

# ABSTRACT: manage human readable external command execution pipelines

use strict;
use warnings;

our $VERSION = '0.13';
use Carp;

use List::Util qw[ sum ];
use Module::Load qw[ load ];
use Module::Runtime
  qw[ check_module_name compose_module_name use_package_optimistically ];
use Safe::Isa;
use Try::Tiny;

use Types::Standard -all;
use Type::Params qw[ validate ];

use IPC::PrettyPipe::Types -all;

use IPC::PrettyPipe::Cmd;
use IPC::PrettyPipe::Queue;
use IPC::PrettyPipe::Arg::Format;

use Moo;
use Moo::Role ();

with 'IPC::PrettyPipe::Queue::Element';

use namespace::clean;

use overload 'fallback' => 1;
















use overload '|=' => sub {
    $_[0]->add( $_[1] );
    return $_[0];
};





















use overload '|' => sub {
    my $swap = pop;
    my $pipe = IPC::PrettyPipe->new;
    $pipe->add( $_ ) for ( $swap ? reverse( @_ ) : @_ );
    $pipe;
};


BEGIN {
    IPC::PrettyPipe::Arg::Format->shadow_attrs( fmt => sub { 'arg' . shift } );
}




























has argfmt => (
    is      => 'ro',
    lazy    => 1,
    handles => IPC::PrettyPipe::Arg::Format->shadowed_attrs,
    default => sub { IPC::PrettyPipe::Arg::Format->new_from_attrs( shift ) },
);



























has streams => (
    is      => 'lazy',
    default => sub {
        IPC::PrettyPipe::Queue->new( elements => $_[0]->_init_streams );
    },
    init_arg => undef,
);


has _init_streams => (
    is       => 'ro',
    isa      => ArrayRef [ InstanceOf ['IPC::PrettyPipe::Stream'] ],
    init_arg => 'streams',
    default  => sub { [] },
);

has _init_cmds => (
    is        => 'ro',
    init_arg  => 'cmds',
    coerce    => AutoArrayRef->coercion,
    isa       => ArrayRef,
    default   => sub { [] },
    predicate => 1,
    clearer   => 1,
);


















# must delay building cmds until all attributes have been specified
has cmds => (
    is       => 'ro',
    default  => sub { IPC::PrettyPipe::Queue->new },
    init_arg => undef,
);











has merge_pipes => (
    is      => 'rw',
    default => 1,
    isa     => Bool,
);

has _executor_arg => (
    is       => 'rw',
    init_arg => 'executor',
    default  => sub { 'IPC::Run' },
    trigger  => sub { $_[0]->_clear_executor },
);


has _executor => (
    is      => 'rw',
    isa     => ConsumerOf ['IPC::PrettyPipe::Executor'],
    lazy    => 1,
    clearer => 1,
    default => sub {

        my $backend = $_[0]->_executor_arg;

        ## no critic (ProhibitAccessOfPrivateData)
        return $backend->$_does( 'IPC::PrettyPipe::Executor' )
          ? $backend
          : $_[0]->_backend_factory( Execute => $backend );
    },
);











sub executor {
    my $self = shift;

    $self->_executor_arg( @_ )
      if @_;

    return $self->_executor;
}









sub run {
    my ( $self ) = @_;

    $self->_executor->run( $self );
}


has _renderer_arg => (
    is       => 'rw',
    init_arg => 'renderer',
    default  => sub { 'Template::Tiny' },
    trigger  => sub { $_[0]->_clear_renderer },
);

has _renderer => (
    is      => 'rw',
    isa     => ConsumerOf ['IPC::PrettyPipe::Renderer'],
    lazy    => 1,
    clearer => 1,
    default => sub {

        my $backend = $_[0]->_renderer_arg;

        ## no critic (ProhibitAccessOfPrivateData)
        return $backend->$_does( 'IPC::PrettyPipe::Renderer' )
          ? $backend
          : $_[0]->_backend_factory( Render => $backend );
    },
);



















sub renderer {
    my $self = shift;

    $self->_renderer_arg( @_ )
      if @_;

    return $self->_renderer;
}









sub render {

    my $self = shift;

    $self->_renderer()->render( $self );
}






# accept:
#  new( \%hash )
#  new( $cmd )
#  new( @stuff )
sub BUILDARGS {

    shift;

    return
        @_ == 1
      ? 'HASH' eq ref( $_[0] )
          ? $_[0]
          : { cmds => $_[0] }
      : {@_};

}


sub BUILD {

    my $self = shift;

    if ( $self->_has_init_cmds ) {

        $self->ffadd( @{ $self->_init_cmds } );
        $self->_clear_init_cmds;
    }

    return;

}



































sub add {

    my $self = shift;

    unshift @_, 'cmd' if @_ == 1;

    ## no critic (ProhibitAccessOfPrivateData)

    my $argfmt = $self->argfmt->clone;

    my $argfmt_attrs = IPC::PrettyPipe::Arg::Format->shadowed_attrs;

    my ( $attr ) = validate(
        \@_,
        slurpy Dict [
            cmd    => Str | Cmd | Pipe,
            args   => Optional,
            argfmt => Optional [ InstanceOf ['IPC::PrettyPipe::Arg::Format'] ],
            ( map { $_ => Optional [Str] } keys %{$argfmt_attrs} ),
        ] );


    $argfmt->copy_from( $attr->{argfmt} ) if defined $attr->{argfmt};
    $argfmt->copy_from( IPC::PrettyPipe::Arg::Format->new_from_hash( $attr ) );


    if ( $attr->{cmd}->$_isa( 'IPC::PrettyPipe::Cmd' ) ) {

        my $cmd = delete $attr->{cmd};

        croak(
            "cannot specify additional arguments when passing a Cmd object\n" )
          if keys %$attr;

        $self->cmds->push( $cmd );

        return $cmd;
    }

    elsif ( $attr->{cmd}->$_isa( 'IPC::PrettyPipe' ) ) {

        my $cmd = delete $attr->{cmd};

        croak(
            "cannot specify additional arguments when passing a Pipe object\n" )
          if keys %$attr;

        if ( $self->merge_pipes && $cmd->streams->empty ) {
            $self->cmds->push( $_ ) foreach @{ $cmd->cmds->elements };
            return $self;
        }
        else {

            $self->cmds->push( $cmd );
            return $cmd;
        }
    }

    else {

        my $cmd = IPC::PrettyPipe::Cmd->new(
            cmd    => $attr->{cmd},
            argfmt => $argfmt->clone,
            exists $attr->{args} ? ( args => $attr->{args} ) : (),
        );

        $self->cmds->push( $cmd );

        return $cmd;

    }

    die( "NOTREACHED" );
}










































sub ffadd {

    my $self = shift;
    my @args = @_;

    my $argfmt = $self->argfmt->clone;

    for ( my $idx = 0 ; $idx < @args ; $idx++ ) {

        my $t = $args[$idx];

        if ( $t->$_isa( 'IPC::PrettyPipe::Arg::Format' ) ) {

            $t->copy_into( $argfmt );

        }

        elsif ( $t->$_isa( 'IPC::PrettyPipe::Cmd' ) ) {

            $self->add( $t );

        }

        elsif ( $t->$_isa( 'IPC::PrettyPipe' ) ) {

            $self->add( $t );

        }

        elsif ( 'ARRAY' eq ref $t ) {

            my $cmd;

            if ( ( $cmd = $t->[0] )->$_isa( 'IPC::PrettyPipe' ) ) {
                croak(
                    "In an array containing an IPC::PrettyPipe object, it must be the only element\n"
                ) if @$t > 1;
            }

            else {

                $cmd = IPC::PrettyPipe::Cmd->new(
                    cmd    => shift( @$t ),
                    argfmt => $argfmt->clone
                );
                $cmd->ffadd( @$t );
            }

            $self->add( $cmd );
        }

        elsif ( $t->$_isa( 'IPC::PrettyPipe::Stream' ) ) {

            $self->stream( $t );

        }

        elsif ( !ref $t ) {

            try {

                my $stream = IPC::PrettyPipe::Stream->new(
                    spec   => $t,
                    strict => 0,
                );

                if ( $stream->requires_file ) {

                    croak( "arg[$idx]: stream operator $t requires a file\n" )
                      if ++$idx == @args;

                    $stream->file( $args[$idx] );
                }

                $self->stream( $stream );
            }
            catch {

                die $_ unless /requires a file|cannot parse/;

                # This is the "fall through" which takes care
                # of calling with a simple string argument, which is
                # taken to be a command to run.  It probably shouldn't
                # be buried at this level of the code.

                $self->add( cmd => $t, argfmt => $argfmt );
            };

        }

        else {

            croak( "arg[$idx]: unrecognized parameter to ffadd\n" );

        }

    }

}












sub stream {

    my $self = shift;

    my $spec = shift;

    if ( $spec->$_isa( 'IPC::PrettyPipe::Stream' ) ) {

        croak( "too many arguments\n" )
          if @_;

        $self->streams->push( $spec );

    }

    elsif ( !ref $spec ) {

        $self->streams->push(
            IPC::PrettyPipe::Stream->new(
                spec => $spec,
                +@_ ? ( file => @_ ) : () ) );
    }

    else {

        croak( "illegal stream specification\n" );

    }


    return;
}












sub valmatch {

    my $self    = shift;
    my $pattern = shift;

    return sum 0,
      map { $_->valmatch( $pattern ) && 1 || 0 } @{ $self->cmds->elements };
}






































































sub valsubst {

    my $self = shift;

    my @args = ( shift, shift, @_ > 1 ? {@_} : @_ );

    my ( $pattern, $value, $args ) = validate(
        \@args,
        RegexpRef,
        Str,
        Optional [
            Dict [
                lastvalue  => Optional [Str],
                firstvalue => Optional [Str] ]
        ],
    );

    my $nmatch = $self->valmatch( $pattern );

    if ( $nmatch == 1 ) {

        ## no critic (ProhibitAccessOfPrivateData)
        $args->{lastvalue}  //= $args->{firstvalue} // $value;
        $args->{firstvalue} //= $args->{lastvalue};

    }
    else {

        ## no critic (ProhibitAccessOfPrivateData)
        $args->{lastvalue}  ||= $value;
        $args->{firstvalue} ||= $value;
    }

    my $match = 0;
    foreach ( @{ $self->cmds->elements } ) {

        ## no critic (ProhibitAccessOfPrivateData)

        $match++
          if $_->valsubst( $pattern,
              $match == 0 ? $args->{firstvalue}
            : $match == ( $nmatch - 1 ) ? $args->{lastvalue}
            :                             $value );
    }

    return $match;
}

sub _backend_factory {

    my ( $self, $type, $req ) = ( shift, shift, shift );

    check_module_name( $req );

    my $role = compose_module_name( __PACKAGE__,
        {
            Render  => 'Renderer',
            Execute => 'Executor'
        }->{$type} );

    my $module;

    for my $try ( $req, compose_module_name( "IPC::PrettyPipe::$type", $req ) )
    {
        next unless use_package_optimistically( $try )->DOES( $role );

        $module = $try;
        last;
    }

    croak(
        "requested $type module ($req) either doesn't exist or doesn't consume $role\n"
    ) if !defined $module;

    return $module->new( @_ );
}


sub _storefh {

    my $self = shift;

    my $sfh = IO::ReStoreFH->new;

    for my $stream ( @{ $self->streams->elements } ) {

        my ( $sub, @fh ) = $stream->apply;

        $sfh->store( $_ ) foreach @fh;

        $sub->();
    }

    return $sfh;
}

1;

#
# This file is part of IPC-PrettyPipe
#
# 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__