File Coverage

blib/lib/PerlX/bash.pm
Criterion Covered Total %
statement 103 103 100.0
branch 67 70 95.7
condition 13 15 86.6
subroutine 18 18 100.0
pod 4 4 100.0
total 205 210 97.6


line stmt bran cond sub pod time code
1             package PerlX::bash;
2              
3 15     15   1702815 use strict;
  15         155  
  15         435  
4 15     15   76 use warnings;
  15         29  
  15         401  
5              
6 15     15   74 use Exporter 'import';
  15         23  
  15         1268  
7             our @EXPORT = ('bash');
8             our @EXPORT_OK = (@EXPORT, qw< shq pwd head tail >);
9             our %EXPORT_TAGS = ( all => \@EXPORT_OK );
10              
11             our $VERSION = '0.04_02'; # TRIAL VERSION
12              
13              
14 15     15   97 use Carp;
  15         30  
  15         1036  
15 15     15   13077 use Contextual::Return;
  15         245703  
  15         146  
16 15     15   25974 use List::Util 1.33 qw< min max any >;
  15         330  
  15         1600  
17 15     15   120 use Scalar::Util qw< blessed >;
  15         28  
  15         650  
18 15     15   8223 use IPC::System::Simple qw< run capture EXIT_ANY $EXITVAL >;
  15         192643  
  15         17409  
19              
20             my $BASH_SPECIAL_CHARS = qr/[ \$'"\\#\[\]!<>|;{}()~]/;
21             my $BASH_REDIRECTION = qr/^\d[<>].+/;
22              
23              
24              
25             my @AUTOQUOTE =
26             (
27             sub { ref shift eq 'Regexp' },
28             sub { blessed $_[0] and $_[0]->can('basename') },
29             );
30              
31             sub _should_quote ()
32             {
33 159     159   249 my $arg = $_;
34 159         224 local $_;
35 159 100   317   1433 return 1 if any { $_->($arg) } @AUTOQUOTE;
  317         836  
36 152 100       3844 return 0 if $arg =~ /^$BASH_SPECIAL_CHARS/;
37 136 100       646 return 0 if $arg =~ $BASH_REDIRECTION;
38 131 100       1175 return 1 if $arg =~ $BASH_SPECIAL_CHARS;
39 95         290 return 0;
40             }
41              
42             sub _process_bash_arg ()
43             {
44             # incoming arg is in $_
45 160     160   292 my $arg = $_; # make a copy
46 160 100       422 croak("Use of uninitialized argument to bash") unless defined $arg;
47 159 100       298 $arg = shq($arg) if _should_quote;
48 159         548 return $arg;
49             }
50              
51              
52              
53             sub bash (@)
54             {
55 63     63 1 91832 my (@opts, $capture);
56 63         832 my $exit_codes = [0..125];
57              
58 63         190 my $dash_c_cmd;
59 63   100     1056 while ( $_[0] and ($_[0] =~ /^-/ or ref $_[0]) )
      100        
60             {
61 47         152 my $arg = shift;
62 47 100       276 if (ref $arg)
    100          
    100          
63             {
64 33 100       160 croak("bash: multiple capture specifications") if $capture;
65 32         259 $capture = $$arg;
66             }
67             elsif ($arg eq '-c')
68             {
69 5         8 $dash_c_cmd = shift;
70 5 100       39 croak("Missing argument for bash -c") unless length($dash_c_cmd);
71             }
72             elsif ($arg eq '-e')
73             {
74 8         115 $exit_codes = [0];
75             }
76             else
77             {
78 1         12 push @opts, $arg;
79             }
80             }
81 60 100       190 if (defined $dash_c_cmd)
82             {
83 3 100       52 croak("Too many arguments for bash -c") if @_;
84             }
85             else
86             {
87 57 100       220 croak("Not enough arguments for bash") unless @_;
88 53 100 66     252 $dash_c_cmd = shift if @_ == 1 and $_[0] and $_[0] =~ /\s/;
      66        
89             }
90              
91 55         130 my $filter;
92 55 100       171 $filter = pop if ref $_[-1] eq 'CODE';
93 55 100 100     365 croak("bash: multiple output redirects") if $capture and $filter;
94              
95 54         184 my @cmd = 'bash';
96 54         128 push @cmd, @opts;
97 54         106 push @cmd, '-c';
98              
99 54 100       221 my $bash_cmd = $dash_c_cmd ? $dash_c_cmd : join(' ', map { _process_bash_arg } @_);
  160         373  
100 53         144 push @cmd, $bash_cmd;
101              
102 53 100       187 if ($capture)
    100          
103             {
104 28         71 my $IFS = $ENV{IFS};
105 28 100       94 $IFS = " \t\n" unless defined $IFS;
106              
107 28         112 my $output = capture $exit_codes, qw< bash -c >, $bash_cmd;
108 27 100       172794 if ($capture eq 'string')
    100          
    100          
109             {
110 21         102 chomp $output;
111 21         1104 return $output;
112             }
113             elsif ($capture eq 'lines')
114             {
115 2         21 my @lines = split("\n", $output);
116 2 100       97 return wantarray ? @lines : $lines[0];
117             }
118             elsif ($capture eq 'words')
119             {
120 3         182 my @words = split(/[$IFS]+/, $output);
121 3 100       155 return wantarray ? @words : $words[0];
122             }
123             else
124             {
125 1         110 die("bash: unrecognized capture specification [$capture]");
126             }
127             }
128             elsif ($filter)
129             {
130 11 100       193 $cmd[-1] =~ s/\s*(?
131 9 100       86 $cmd[-1] .= ' 2>&1' if $1;
132              
133             # This is pretty much straight out of `man perlipc`.
134 9         32 local *CHILD;
135 9         9603 my $pid = open(CHILD, "-|");
136 9 50       886 defined($pid) or die("bash: can't fork [$!]");
137              
138 9 100       205 if ($pid) # parent
139             {
140 6         95 local $_;
141 6         1497949 while ()
142             {
143 60         487 chomp;
144 60         265 $filter->($_);
145             }
146 6 100       1946 unless (close(CHILD))
147             {
148             # You know how IPC::System::Simple says that `_process_child_error` is not intended
149             # to be called directly? Yeah, well, the alternatives are worse ...
150 1         59 IPC::System::Simple::_process_child_error($?, 'bash', $exit_codes);
151             }
152             }
153             else # child
154             {
155 3 0       0 exec(@cmd) or die("bash: can't exec program [$!]");
156             }
157             }
158             else
159             {
160 14         66 run $exit_codes, @cmd;
161             return
162 2     2   1126 BOOL { $EXITVAL == 0 }
163 3     3   3844 SCALAR { $EXITVAL }
164 12         78982 ;
165             }
166             }
167              
168              
169             sub shq
170             {
171 46     46 1 1468 local $_ = shift;
172             #$_ = "$_"; # stringify
173 46         285 s/'/'\\''/g; # handle internal single quotes
174 46         237 "'$_'"; # quote with single quotes
175             }
176              
177              
178              
179 15     15   140 use Cwd ();
  15         43  
  15         2549  
180             *pwd = \&Cwd::cwd;
181              
182              
183              
184             sub head
185             {
186 7     7 1 1107 my $num = shift;
187 7 100       52 $num = $num < 0 ? @_ + $num : min($num, scalar @_);
188 7         48 @_[0..$num-1];
189             }
190              
191             sub tail
192             {
193 7     7 1 1135 my $num = shift;
194 7 100       20 return () unless $num;
195 6 100       21 $num = $num < 0 ? max(@_ + $num, 0) : $num - 1 ;
196 6         33 @_[$num..$#_];
197             }
198              
199              
200             1;
201              
202             # ABSTRACT: tighter integration between Perl and bash
203             # COPYRIGHT
204             #
205             # This module is similar to the solution presented here:
206             # http://stackoverflow.com/questions/571368/how-can-i-use-bash-syntax-in-perls-system
207              
208             __END__