File Coverage

blib/lib/IPC/PrettyPipe/Cmd.pm

Criterion	Covered	Total	%
statement	121	128	94.5
branch	36	56	64.2
condition	12	21	57.1
subroutine	26	26	100.0
pod	6	8	75.0
total	201	239	84.1

package IPC::PrettyPipe::Cmd;

# ABSTRACT: A command in an B pipeline

use Carp;

use List::Util qw[ sum pairs ];
use Scalar::Util qw[ blessed ];

use Try::Tiny;

use Safe::Isa;

use IPC::PrettyPipe::Arg;
use IPC::PrettyPipe::Stream;

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

use IPC::PrettyPipe::Types -all;
use IPC::PrettyPipe::Queue;
use IPC::PrettyPipe::Arg::Format;

use String::ShellQuote 'shell_quote';

use Moo;

our $VERSION = '0.12';

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

use namespace::clean;


# need access to has method which will get removed at the end of the
# compilation of this module
BEGIN {
    IPC::PrettyPipe::Arg::Format->shadow_attrs( fmt => sub { 'arg' . shift } );
}

has cmd => (
    is       => 'ro',
    isa      => Str,
    required => 1,
);

# delay building args until all attributes have been specified
has _init_args => (
    is        => 'ro',
    init_arg  => 'args',
    coerce    => AutoArrayRef->coercion,
    isa       => ArrayRef,
    predicate => 1,
    clearer   => 1,
);

has args => (
    is       => 'ro',
    default  => sub { IPC::PrettyPipe::Queue->new },
    init_arg => undef,
);

has streams => (
    is       => 'ro',
    default  => sub { IPC::PrettyPipe::Queue->new },
    init_arg => undef,
);

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





sub BUILDARGS {

    my $class = shift;

    my $args
      = @_ == 1
      ? (
        'HASH' eq ref( $_[0] )
        ? $_[0]
        : 'ARRAY' eq ref( $_[0] )
          && @{ $_[0] } == 2 ? { cmd => $_[0][0], args => $_[0][1] }
        : { cmd => $_[0] } )
      : {@_};

    ## no critic (ProhibitAccessOfPrivateData)
    delete @{$args}{ grep { !defined $args->{$_} } keys %$args };

    return $args;
}


sub BUILD {


    my $self = shift;

    if ( $self->_has_init_args ) {

        $self->ffadd( @{ $self->_init_args } );
        $self->_clear_init_args;
    }

    return;
}

sub quoted_cmd { shell_quote( $_[0]->cmd ) }

sub add {

    my $self = shift;

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

    ## no critic (ProhibitAccessOfPrivateData)

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

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

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

    my $arg = $attr->{arg};
    my $ref = ref $arg;

    croak( "cannot specify a value if arg is a hash, array, or Arg object\n" )
      if $ref && exists $attr->{value};

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

    if ( 'HASH' eq $ref ) {

        while ( my ( $name, $value ) = each %$arg ) {

            $self->args->push(
                IPC::PrettyPipe::Arg->new(
                    name  => $name,
                    value => $value,
                    fmt   => $argfmt->clone
                ) );

        }
    }

    elsif ( 'ARRAY' eq $ref ) {

        croak( "missing value for argument ", $arg->[-1] )
          if @$arg % 2;

        foreach ( pairs @$arg ) {

            my ( $name, $value ) = @$_;

            $self->args->push(
                IPC::PrettyPipe::Arg->new(
                    name  => $name,
                    value => $value,
                    fmt   => $argfmt->clone
                ) );

        }
    }

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

        $self->args->push( $arg );

    }

    # everything else
    else {

        $self->args->push(
            IPC::PrettyPipe::Arg->new(
                name => $attr->{arg},
                exists $attr->{value} ? ( value => $attr->value ) : (),
                fmt => $argfmt->clone
            ) );
    }

    return;
}


# free form add
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::Arg' ) ) {

            $self->add( arg => $t );


        }

        elsif ( ref( $t ) =~ /^(ARRAY|HASH)$/ ) {

            $self->add( arg => $t, argfmt => $argfmt->clone );

        }

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

            $self->stream( $t );

        }

        else {

            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 $_ if /requires a file/;

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

        }
    }

    return;
}

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;

    # find number of matches;
    return sum 0, map { $_->valmatch( $pattern ) } @{ $self->args->elements };
}

sub valsubst {
    my $self = shift;

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


    ## no critic (ProhibitAccessOfPrivateData)

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

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

    if ( $nmatch == 1 ) {

        $args->{lastvalue}  //= $args->{firstvalue} // $value;
        $args->{firstvalue} //= $args->{lastvalue};

    }
    else {
        $args->{lastvalue}  ||= $value;
        $args->{firstvalue} ||= $value;
    }

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

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

    return $match;
}


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__