File Coverage

blib/lib/ExtUtils/Command.pm
Criterion Covered Total %
statement 85 101 84.1
branch 25 40 62.5
condition 7 15 46.6
subroutine 18 18 100.0
pod 12 13 92.3
total 147 187 78.6


line stmt bran cond sub pod time code
1             package ExtUtils::Command;
2              
3 2     2   15926 use 5.00503;
  2         7  
  2         80  
4 2     2   12 use strict;
  2         3  
  2         82  
5             require Exporter;
6 2     2   14 use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
  2         6  
  2         3052  
7             @ISA = qw(Exporter);
8             @EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod
9             dos2unix);
10             $VERSION = '1.19';
11              
12             my $Is_VMS = $^O eq 'VMS';
13             my $Is_VMS_mode = $Is_VMS;
14             my $Is_VMS_noefs = $Is_VMS;
15             my $Is_Win32 = $^O eq 'MSWin32';
16              
17             if( $Is_VMS ) {
18             my $vms_unix_rpt;
19             my $vms_efs;
20             my $vms_case;
21              
22             if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
23             $vms_unix_rpt = VMS::Feature::current("filename_unix_report");
24             $vms_efs = VMS::Feature::current("efs_charset");
25             $vms_case = VMS::Feature::current("efs_case_preserve");
26             } else {
27             my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
28             my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || '';
29             my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || '';
30             $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i;
31             $vms_efs = $efs_charset =~ /^[ET1]/i;
32             $vms_case = $efs_case =~ /^[ET1]/i;
33             }
34             $Is_VMS_mode = 0 if $vms_unix_rpt;
35             $Is_VMS_noefs = 0 if ($vms_efs);
36             }
37              
38              
39             =head1 NAME
40              
41             ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc.
42              
43             =head1 SYNOPSIS
44              
45             perl -MExtUtils::Command -e cat files... > destination
46             perl -MExtUtils::Command -e mv source... destination
47             perl -MExtUtils::Command -e cp source... destination
48             perl -MExtUtils::Command -e touch files...
49             perl -MExtUtils::Command -e rm_f files...
50             perl -MExtUtils::Command -e rm_rf directories...
51             perl -MExtUtils::Command -e mkpath directories...
52             perl -MExtUtils::Command -e eqtime source destination
53             perl -MExtUtils::Command -e test_f file
54             perl -MExtUtils::Command -e test_d directory
55             perl -MExtUtils::Command -e chmod mode files...
56             ...
57              
58             =head1 DESCRIPTION
59              
60             The module is used to replace common UNIX commands. In all cases the
61             functions work from @ARGV rather than taking arguments. This makes
62             them easier to deal with in Makefiles. Call them like this:
63              
64             perl -MExtUtils::Command -e some_command some files to work on
65              
66             and I like this:
67              
68             perl -MExtUtils::Command -e 'some_command qw(some files to work on)'
69              
70             For that use L.
71              
72             Filenames with * and ? will be glob expanded.
73              
74              
75             =head2 FUNCTIONS
76              
77             =over 4
78              
79             =cut
80              
81             # VMS uses % instead of ? to mean "one character"
82             my $wild_regex = $Is_VMS ? '*%' : '*?';
83             sub expand_wildcards
84             {
85 25 100   25 0 1382 @ARGV = map(/[$wild_regex]/o ? glob($_) : $_,@ARGV);
86             }
87              
88              
89             =item cat
90              
91             cat file ...
92              
93             Concatenates all files mentioned on command line to STDOUT.
94              
95             =cut
96              
97             sub cat ()
98             {
99 1     1 1 92 expand_wildcards();
100 1         57 print while (<>);
101             }
102              
103             =item eqtime
104              
105             eqtime source destination
106              
107             Sets modified time of destination to that of source.
108              
109             =cut
110              
111             sub eqtime
112             {
113 2     2 1 1021 my ($src,$dst) = @ARGV;
114 2         4 local @ARGV = ($dst); touch(); # in case $dst doesn't exist
  2         5  
115 2         36 utime((stat($src))[8,9],$dst);
116             }
117              
118             =item rm_rf
119              
120             rm_rf files or directories ...
121              
122             Removes files and directories - recursively (even if readonly)
123              
124             =cut
125              
126             sub rm_rf
127             {
128 2     2 1 1113 expand_wildcards();
129 2         12 require File::Path;
130 2         777 File::Path::rmtree([grep -e $_,@ARGV],0,0);
131             }
132              
133             =item rm_f
134              
135             rm_f file ...
136              
137             Removes files (even if readonly)
138              
139             =cut
140              
141             sub rm_f {
142 1     1 1 559 expand_wildcards();
143              
144 1         3 foreach my $file (@ARGV) {
145 2 50       22 next unless -f $file;
146              
147 2 50       5 next if _unlink($file);
148              
149 0         0 chmod(0777, $file);
150              
151 0 0       0 next if _unlink($file);
152              
153 0         0 require Carp;
154 0         0 Carp::carp("Cannot delete $file: $!");
155             }
156             }
157              
158             sub _unlink {
159 2     2   1 my $files_unlinked = 0;
160 2         4 foreach my $file (@_) {
161 2         2 my $delete_count = 0;
162 2         137 $delete_count++ while unlink $file;
163 2 50       8 $files_unlinked++ if $delete_count;
164             }
165 2         7 return $files_unlinked;
166             }
167              
168              
169             =item touch
170              
171             touch file ...
172              
173             Makes files exist, with current timestamp
174              
175             =cut
176              
177             sub touch {
178 4     4 1 2003246 my $t = time;
179 4         9 expand_wildcards();
180 4         31 foreach my $file (@ARGV) {
181 4 50       258 open(FILE,">>$file") || die "Cannot write $file:$!";
182 4         28 close(FILE);
183 4         90 utime($t,$t,$file);
184             }
185             }
186              
187             =item mv
188              
189             mv source_file destination_file
190             mv source_file source_file destination_dir
191              
192             Moves source to destination. Multiple sources are allowed if
193             destination is an existing directory.
194              
195             Returns true if all moves succeeded, false otherwise.
196              
197             =cut
198              
199             sub mv {
200 2     2 1 463 expand_wildcards();
201 2         21 my @src = @ARGV;
202 2         4 my $dst = pop @src;
203              
204 2 100 66     16 if (@src > 1 && ! -d $dst) {
205 1         5 require Carp;
206 1         89 Carp::croak("Too many arguments");
207             }
208              
209 1         5 require File::Copy;
210 1         1 my $nok = 0;
211 1         3 foreach my $src (@src) {
212 1   33     4 $nok ||= !File::Copy::move($src,$dst);
213             }
214 1         135 return !$nok;
215             }
216              
217             =item cp
218              
219             cp source_file destination_file
220             cp source_file source_file destination_dir
221              
222             Copies sources to the destination. Multiple sources are allowed if
223             destination is an existing directory.
224              
225             Returns true if all copies succeeded, false otherwise.
226              
227             =cut
228              
229             sub cp {
230 3     3 1 1698 expand_wildcards();
231 3         8 my @src = @ARGV;
232 3         5 my $dst = pop @src;
233              
234 3 100 66     23 if (@src > 1 && ! -d $dst) {
235 1         7 require Carp;
236 1         200 Carp::croak("Too many arguments");
237             }
238              
239 2         1210 require File::Copy;
240 2         3932 my $nok = 0;
241 2         7 foreach my $src (@src) {
242 2   33     14 $nok ||= !File::Copy::copy($src,$dst);
243              
244             # Win32 does not update the mod time of a copied file, just the
245             # created time which make does not look at.
246 2 50       592 utime(time, time, $dst) if $Is_Win32;
247             }
248 2         6 return $nok;
249             }
250              
251             =item chmod
252              
253             chmod mode files ...
254              
255             Sets UNIX like permissions 'mode' on all the files. e.g. 0666
256              
257             =cut
258              
259             sub chmod {
260 7     7 1 3223 local @ARGV = @ARGV;
261 7         13 my $mode = shift(@ARGV);
262 7         11 expand_wildcards();
263              
264 7 50 33     20 if( $Is_VMS_mode && $Is_VMS_noefs) {
265 0         0 require File::Spec;
266 0         0 foreach my $idx (0..$#ARGV) {
267 0         0 my $path = $ARGV[$idx];
268 0 0       0 next unless -d $path;
269              
270             # chmod 0777, [.foo.bar] doesn't work on VMS, you have to do
271             # chmod 0777, [.foo]bar.dir
272 0         0 my @dirs = File::Spec->splitdir( $path );
273 0         0 $dirs[-1] .= '.dir';
274 0         0 $path = File::Spec->catfile(@dirs);
275              
276 0         0 $ARGV[$idx] = $path;
277             }
278             }
279              
280 7 50       179 chmod(oct $mode,@ARGV) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!";
281             }
282              
283             =item mkpath
284              
285             mkpath directory ...
286              
287             Creates directories, including any parent directories.
288              
289             =cut
290              
291             sub mkpath
292             {
293 3     3 1 2372 expand_wildcards();
294 3         18 require File::Path;
295 3         479 File::Path::mkpath([@ARGV],0,0777);
296             }
297              
298             =item test_f
299              
300             test_f file
301              
302             Tests if a file exists. I with 0 if it does, 1 if it does not (ie.
303             shell's idea of true and false).
304              
305             =cut
306              
307             sub test_f
308             {
309 2 100   2 1 2807 exit(-f $ARGV[0] ? 0 : 1);
310             }
311              
312             =item test_d
313              
314             test_d directory
315              
316             Tests if a directory exists. I with 0 if it does, 1 if it does
317             not (ie. shell's idea of true and false).
318              
319             =cut
320              
321             sub test_d
322             {
323 2 100   2 1 1153 exit(-d $ARGV[0] ? 0 : 1);
324             }
325              
326             =item dos2unix
327              
328             dos2unix files or dirs ...
329              
330             Converts DOS and OS/2 linefeeds to Unix style recursively.
331              
332             =cut
333              
334             sub dos2unix {
335 1     1 1 218 require File::Find;
336             File::Find::find(sub {
337 3 100   3   79 return if -d;
338 2 50       9 return unless -w _;
339 2 50       5 return unless -r _;
340 2 100       93 return if -B _;
341              
342 1         5 local $\;
343              
344 1         2 my $orig = $_;
345 1         3 my $temp = '.dos2unix_tmp';
346 1 50       25 open ORIG, $_ or do { warn "dos2unix can't open $_: $!"; return };
  0         0  
  0         0  
347             open TEMP, ">$temp" or
348 1 50       63 do { warn "dos2unix can't create .dos2unix_tmp: $!"; return };
  0         0  
  0         0  
349 1         11 while (my $line = ) {
350 2         6 $line =~ s/\015\012/\012/g;
351 2         16 print TEMP $line;
352             }
353 1         6 close ORIG;
354 1         22 close TEMP;
355 1         66 rename $temp, $orig;
356              
357 1         77 }, @ARGV);
358             }
359              
360             =back
361              
362             =head1 SEE ALSO
363              
364             Shell::Command which is these same functions but take arguments normally.
365              
366              
367             =head1 AUTHOR
368              
369             Nick Ing-Simmons C
370              
371             Maintained by Michael G Schwern C within the
372             ExtUtils-MakeMaker package and, as a separate CPAN package, by
373             Randy Kobes C.
374              
375             =cut