File Coverage

blib/lib/IPC/PrettyPipe.pm
Criterion Covered Total %
statement 148 155 95.4
branch 44 70 62.8
condition 12 17 70.5
subroutine 30 31 96.7
pod 7 9 77.7
total 241 282 85.4


line stmt bran cond sub pod time code
1             package IPC::PrettyPipe;
2              
3             # ABSTRACT: manage human readable external command execution pipelines
4              
5 12     12   947291 use strict;
  12         47  
  12         317  
6 12     12   55 use warnings;
  12         20  
  12         431  
7              
8             our $VERSION = '0.12';
9 12     12   63 use Carp;
  12         22  
  12         666  
10              
11 12     12   68 use List::Util qw[ sum ];
  12         28  
  12         726  
12 12     12   5447 use Module::Load qw[ load ];
  12         12240  
  12         67  
13             use Module::Runtime
14 12     12   5844 qw[ check_module_name compose_module_name use_package_optimistically ];
  12         18806  
  12         72  
15 12     12   2613 use Safe::Isa;
  12         2028  
  12         1266  
16 12     12   5245 use Try::Tiny;
  12         21833  
  12         685  
17              
18 12     12   5973 use Types::Standard -all;
  12         775543  
  12         136  
19 12     12   536149 use Type::Params qw[ validate ];
  12         124154  
  12         130  
20              
21 12     12   7790 use IPC::PrettyPipe::Types -all;
  12         38  
  12         133  
22              
23 12     12   34860 use IPC::PrettyPipe::Cmd;
  12         46  
  12         394  
24 12     12   83 use IPC::PrettyPipe::Queue;
  12         21  
  12         215  
25 12     12   56 use IPC::PrettyPipe::Arg::Format;
  12         21  
  12         181  
26              
27 12     12   51 use Moo;
  12         22  
  12         48  
28 12     12   7973 use Moo::Role ();
  12         27  
  12         294  
29              
30             with 'IPC::PrettyPipe::Queue::Element';
31              
32 12     12   57 use namespace::clean;
  12         26  
  12         98  
33              
34             BEGIN {
35 12     12   21244 IPC::PrettyPipe::Arg::Format->shadow_attrs( fmt => sub { 'arg' . shift } );
  24         11005  
36             }
37              
38              
39              
40              
41              
42              
43              
44              
45              
46              
47              
48              
49              
50              
51              
52              
53              
54              
55              
56              
57              
58              
59              
60              
61              
62             has argfmt => (
63             is => 'ro',
64             lazy => 1,
65             handles => IPC::PrettyPipe::Arg::Format->shadowed_attrs,
66             default => sub { IPC::PrettyPipe::Arg::Format->new_from_attrs( shift ) },
67             );
68              
69              
70              
71              
72              
73              
74              
75              
76              
77              
78              
79              
80              
81              
82              
83              
84              
85              
86              
87              
88              
89              
90             has streams => (
91             is => 'ro',
92             default => sub { IPC::PrettyPipe::Queue->new },
93             init_arg => undef,
94             );
95              
96              
97             has _init_cmds => (
98             is => 'ro',
99             init_arg => 'cmds',
100             coerce => AutoArrayRef->coercion,
101             isa => ArrayRef,
102             default => sub { [] },
103             predicate => 1,
104             clearer => 1,
105             );
106              
107              
108              
109              
110              
111              
112              
113              
114              
115              
116              
117              
118              
119              
120              
121              
122              
123              
124             # must delay building cmds until all attributes have been specified
125             has cmds => (
126             is => 'ro',
127             default => sub { IPC::PrettyPipe::Queue->new },
128             init_arg => undef,
129             );
130              
131             has _executor_arg => (
132             is => 'rw',
133             init_arg => 'executor',
134             default => sub { 'IPC::Run' },
135             trigger => sub { $_[0]->_clear_executor },
136             );
137              
138              
139             has _executor => (
140             is => 'rw',
141             isa => ConsumerOf ['IPC::PrettyPipe::Executor'],
142             handles => 'IPC::PrettyPipe::Executor',
143             lazy => 1,
144             clearer => 1,
145             default => sub {
146              
147             my $backend = $_[0]->_executor_arg;
148              
149             ## no critic (ProhibitAccessOfPrivateData)
150             return $backend->$_does( 'IPC::PrettyPipe::Executor' )
151             ? $backend
152             : $_[0]->_backend_factory( Execute => $backend );
153             },
154             );
155              
156              
157              
158              
159              
160              
161              
162              
163              
164              
165              
166             sub executor {
167 10     10 1 99 my $self = shift;
168              
169 10 100       189 $self->_executor_arg( @_ )
170             if @_;
171              
172 10         248 return $self->_executor;
173             }
174              
175              
176              
177              
178              
179              
180              
181              
182              
183              
184             has _renderer_arg => (
185             is => 'rw',
186             init_arg => 'renderer',
187             default => sub { 'Template::Tiny' },
188             trigger => sub { $_[0]->_clear_renderer },
189             );
190              
191             has _renderer => (
192             is => 'rw',
193             isa => ConsumerOf ['IPC::PrettyPipe::Renderer'],
194             handles => 'IPC::PrettyPipe::Renderer',
195             lazy => 1,
196             clearer => 1,
197             default => sub {
198              
199             my $backend = $_[0]->_renderer_arg;
200              
201             ## no critic (ProhibitAccessOfPrivateData)
202             return $backend->$_does( 'IPC::PrettyPipe::Renderer' )
203             ? $backend
204             : $_[0]->_backend_factory( Render => $backend );
205             },
206             );
207              
208              
209              
210              
211              
212              
213              
214              
215              
216              
217             sub renderer {
218 11     11 1 5022 my $self = shift;
219              
220 11 100       45 $self->_renderer_arg( @_ )
221             if @_;
222              
223 11         184 return $self->_renderer;
224             }
225              
226              
227              
228              
229              
230              
231              
232              
233              
234              
235              
236              
237              
238              
239             # accept:
240             # new( \%hash )
241             # new( $cmd )
242             # new( @stuff )
243             sub BUILDARGS {
244              
245 69     69 0 88298 shift;
246              
247             return
248 69 0       1318 @_ == 1
    50          
249             ? 'HASH' eq ref( $_[0] )
250             ? $_[0]
251             : { cmds => $_[0] }
252             : {@_};
253              
254             }
255              
256              
257             sub BUILD {
258              
259 69     69 0 394 my $self = shift;
260              
261 69 50       350 if ( $self->_has_init_cmds ) {
262              
263 69         130 $self->ffadd( @{ $self->_init_cmds } );
  69         362  
264 69         1410 $self->_clear_init_cmds;
265             }
266              
267 69         602 return;
268              
269             }
270              
271              
272              
273              
274              
275              
276              
277              
278              
279              
280              
281              
282              
283              
284              
285              
286              
287              
288              
289              
290              
291              
292              
293              
294              
295              
296              
297              
298              
299              
300              
301              
302              
303              
304              
305             sub add {
306              
307 80     80 1 163 my $self = shift;
308              
309 80 50       294 unshift @_, 'cmd' if @_ == 1;
310              
311             ## no critic (ProhibitAccessOfPrivateData)
312              
313 80         1616 my $argfmt = $self->argfmt->clone;
314              
315 80         302 my $argfmt_attrs = IPC::PrettyPipe::Arg::Format->shadowed_attrs;
316              
317             my ( $attr ) = validate(
318             \@_,
319             slurpy Dict [
320             cmd => Str | Cmd | Pipe,
321             args => Optional,
322             argfmt => Optional [ InstanceOf ['IPC::PrettyPipe::Arg::Format'] ],
323 80         2852 ( map { $_ => Optional [Str] } keys %{$argfmt_attrs} ),
  160         45698  
  80         112616  
324             ] );
325              
326              
327 80         708803 my $cmd;
328              
329 80 50       18191 $argfmt->copy_from( $attr->{argfmt} ) if defined $attr->{argfmt};
330 80         469 $argfmt->copy_from( IPC::PrettyPipe::Arg::Format->new_from_hash( $attr ) );
331              
332              
333 80 100       443 if ( $attr->{cmd}->$_isa( 'IPC::PrettyPipe::Cmd' ) ) {
    50          
334              
335 75         1349 $cmd = delete $attr->{cmd};
336              
337 75 50       310 croak(
338             "cannot specify additional arguments when passing a Cmd object\n" )
339             if keys %$attr;
340             }
341              
342             elsif ( $attr->{cmd}->$_isa( 'IPC::PrettyPipe' ) ) {
343              
344 5         149 $cmd = delete $attr->{cmd};
345              
346 5 50       22 croak(
347             "cannot specify additional arguments when passing a Pipe object\n" )
348             if keys %$attr;
349             }
350              
351             else {
352              
353             $cmd = IPC::PrettyPipe::Cmd->new(
354             cmd => $attr->{cmd},
355             argfmt => $argfmt->clone,
356 0 0       0 exists $attr->{args} ? ( args => $attr->{args} ) : (),
357             );
358             }
359              
360 80         545 $self->cmds->push( $cmd );
361              
362 80         636 return $cmd;
363             }
364              
365              
366              
367              
368              
369              
370              
371              
372              
373              
374              
375              
376              
377              
378              
379              
380              
381              
382              
383              
384              
385              
386              
387              
388              
389              
390              
391              
392              
393              
394              
395              
396              
397              
398              
399              
400              
401              
402              
403              
404              
405              
406             sub ffadd {
407              
408 126     126 1 223 my $self = shift;
409 126         279 my @args = @_;
410              
411 126         2057 my $argfmt = $self->argfmt->clone;
412              
413 126         524 for ( my $idx = 0 ; $idx < @args ; $idx++ ) {
414              
415 94         256 my $t = $args[$idx];
416              
417 94 100       278 if ( $t->$_isa( 'IPC::PrettyPipe::Arg::Format' ) ) {
    100          
    100          
    100          
    50          
    50          
418              
419 4         53 $t->copy_into( $argfmt );
420              
421             }
422              
423             elsif ( $t->$_isa( 'IPC::PrettyPipe::Cmd' ) ) {
424              
425 1         34 $self->add( $t );
426              
427             }
428              
429             elsif ( $t->$_isa( 'IPC::PrettyPipe' ) ) {
430              
431 1         37 $self->add( $t );
432              
433             }
434              
435             elsif ( 'ARRAY' eq ref $t ) {
436              
437 78         1820 my $cmd;
438              
439 78 100       254 if ( ( $cmd = $t->[0])->$_isa( 'IPC::PrettyPipe' ) ) {
440 4 50       76 croak( "In an array containing an IPC::PrettyPipe object, it must be the only element\n" )
441             if @$t > 1;
442             }
443              
444             else {
445              
446 74         766 $cmd = IPC::PrettyPipe::Cmd->new(
447             cmd => shift( @$t ),
448             argfmt => $argfmt->clone
449             );
450 74         346 $cmd->ffadd( @$t );
451             }
452              
453 78         322 $self->add( $cmd );
454             }
455              
456             elsif ( $t->$_isa( 'IPC::PrettyPipe::Stream' ) ) {
457              
458 0         0 $self->stream( $t );
459              
460             }
461              
462             elsif ( !ref $t ) {
463              
464             try {
465              
466 10     10   693 my $stream = IPC::PrettyPipe::Stream->new(
467             spec => $t,
468             strict => 0,
469             );
470              
471 10 50       42 if ( $stream->requires_file ) {
472              
473 10 50       40 croak( "arg[$idx]: stream operator $t requires a file\n" )
474             if ++$idx == @args;
475              
476 10         191 $stream->file( $args[$idx] );
477             }
478              
479 10         308 $self->stream( $stream );
480             }
481             catch {
482              
483 0 0   0   0 die $_ unless /requires a file|cannot parse/;
484              
485             # This is the "fall through" which takes care
486             # of calling with a simple string argument, which is
487             # taken to be a command to run. It probably shouldn't
488             # be buried at this level of the code.
489              
490 0         0 $self->add( cmd => $t, argfmt => $argfmt );
491 10         421 };
492              
493             }
494              
495             else {
496              
497 0         0 croak( "arg[$idx]: unrecognized parameter to ffadd\n" );
498              
499             }
500              
501             }
502              
503             }
504              
505              
506              
507              
508              
509              
510              
511              
512              
513              
514              
515              
516             sub stream {
517              
518 10     10 1 22 my $self = shift;
519              
520 10         17 my $spec = shift;
521              
522 10 50       33 if ( $spec->$_isa( 'IPC::PrettyPipe::Stream' ) ) {
    0          
523              
524 10 50       162 croak( "too many arguments\n" )
525             if @_;
526              
527 10         48 $self->streams->push( $spec );
528              
529             }
530              
531             elsif ( !ref $spec ) {
532              
533 0 0       0 $self->streams->push(
534             IPC::PrettyPipe::Stream->new(
535             spec => $spec,
536             +@_ ? ( file => @_ ) : () ) );
537             }
538              
539             else {
540              
541 0         0 croak( "illegal stream specification\n" );
542              
543             }
544              
545              
546 10         28 return;
547             }
548              
549              
550              
551              
552              
553              
554              
555              
556              
557              
558              
559              
560             sub valmatch {
561              
562 16     16 1 1731 my $self = shift;
563 16         30 my $pattern = shift;
564              
565             return sum 0,
566 16 100 100     26 map { $_->valmatch( $pattern ) && 1 || 0 } @{ $self->cmds->elements };
  26         84  
  16         54  
567             }
568              
569              
570              
571              
572              
573              
574              
575              
576              
577              
578              
579              
580              
581              
582              
583              
584              
585              
586              
587              
588              
589              
590              
591              
592              
593              
594              
595              
596              
597              
598              
599              
600              
601              
602              
603              
604              
605              
606              
607              
608              
609              
610              
611              
612              
613              
614              
615              
616              
617              
618              
619              
620              
621              
622              
623              
624              
625              
626              
627              
628              
629              
630              
631              
632              
633              
634              
635              
636              
637              
638             sub valsubst {
639              
640 12     12 1 110 my $self = shift;
641              
642 12 100       53 my @args = ( shift, shift, @_ > 1 ? {@_} : @_ );
643              
644 12         56 my ( $pattern, $value, $args ) = validate(
645             \@args,
646             RegexpRef,
647             Str,
648             Optional [
649             Dict [
650             lastvalue => Optional [Str],
651             firstvalue => Optional [Str] ]
652             ],
653             );
654              
655 12         54903 my $nmatch = $self->valmatch( $pattern );
656              
657 12 100       42 if ( $nmatch == 1 ) {
658              
659             ## no critic (ProhibitAccessOfPrivateData)
660 5   66     30 $args->{lastvalue} //= $args->{firstvalue} // $value;
      66        
661 5   66     18 $args->{firstvalue} //= $args->{lastvalue};
662              
663             }
664             else {
665              
666             ## no critic (ProhibitAccessOfPrivateData)
667 7   66     31 $args->{lastvalue} ||= $value;
668 7   66     45 $args->{firstvalue} ||= $value;
669             }
670              
671 12         24 my $match = 0;
672 12         16 foreach ( @{ $self->cmds->elements } ) {
  12         57  
673              
674             ## no critic (ProhibitAccessOfPrivateData)
675              
676             $match++
677             if $_->valsubst( $pattern,
678             $match == 0 ? $args->{firstvalue}
679             : $match == ( $nmatch - 1 ) ? $args->{lastvalue}
680 22 100       90 : $value );
    100          
    50          
681             }
682              
683 12         45 return $match;
684             }
685              
686             sub _backend_factory {
687              
688 39     39   597 my ( $self, $type, $req ) = ( shift, shift, shift );
689              
690 39         230 check_module_name( $req );
691              
692             my $role = compose_module_name( __PACKAGE__,
693             {
694             Render => 'Renderer',
695             Execute => 'Executor'
696 39         1055 }->{$type} );
697              
698 39         2182 my $module;
699              
700 39         140 for my $try ( $req, compose_module_name( "IPC::PrettyPipe::$type", $req ) )
701             {
702 74 100       60507 next unless use_package_optimistically( $try )->DOES( $role );
703              
704 39         47335 $module = $try;
705 39         91 last;
706             }
707              
708             croak(
709 39 50       141 "requested $type module ($req) either doesn't exist or doesn't consume $role\n"
710             ) if !defined $module;
711              
712 39         688 return $module->new( pipe => $self, @_ );
713             }
714              
715              
716             sub _storefh {
717              
718 6     6   15 my $self = shift;
719              
720 6         107 my $sfh = IO::ReStoreFH->new;
721              
722 6         119 for my $stream ( @{ $self->streams->elements } ) {
  6         60  
723              
724 4         42 my ( $sub, @fh ) = $stream->apply;
725              
726 4         21 $sfh->store( $_ ) foreach @fh;
727              
728 4         608 $sub->();
729             }
730              
731 6         34 return $sfh;
732             }
733              
734             1;
735              
736             #
737             # This file is part of IPC-PrettyPipe
738             #
739             # This software is Copyright (c) 2018 by Smithsonian Astrophysical Observatory.
740             #
741             # This is free software, licensed under:
742             #
743             # The GNU General Public License, Version 3, June 2007
744             #
745              
746             __END__