This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to ExtUtils::MakeMaker 6.25
[perl5.git] / lib / ExtUtils / Command.pm
1 package ExtUtils::Command;
2
3 use 5.00503;
4 use strict;
5 use Carp;
6 use File::Copy;
7 use File::Compare;
8 use File::Basename;
9 use File::Path qw(rmtree);
10 require Exporter;
11 use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
12 @ISA       = qw(Exporter);
13 @EXPORT    = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f chmod 
14                 dos2unix);
15 $VERSION = '1.07';
16
17 my $Is_VMS = $^O eq 'VMS';
18
19 =head1 NAME
20
21 ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc.
22
23 =head1 SYNOPSIS
24
25   perl -MExtUtils::Command       -e cat files... > destination
26   perl -MExtUtils::Command       -e mv source... destination
27   perl -MExtUtils::Command       -e cp source... destination
28   perl -MExtUtils::Command       -e touch files...
29   perl -MExtUtils::Command       -e rm_f files...
30   perl -MExtUtils::Command       -e rm_rf directories...
31   perl -MExtUtils::Command       -e mkpath directories...
32   perl -MExtUtils::Command       -e eqtime source destination
33   perl -MExtUtils::Command       -e test_f file
34   perl -MExtUtils::Command       -e chmod mode files...
35   ...
36
37 =head1 DESCRIPTION
38
39 The module is used to replace common UNIX commands.  In all cases the
40 functions work from @ARGV rather than taking arguments.  This makes
41 them easier to deal with in Makefiles.
42
43   perl -MExtUtils::Command -e some_command some files to work on
44
45 I<NOT>
46
47   perl -MExtUtils::Command -e 'some_command qw(some files to work on)'
48
49 Filenames with * and ? will be glob expanded.
50
51 =over 4
52
53 =cut
54
55 # VMS uses % instead of ? to mean "one character"
56 my $wild_regex = $Is_VMS ? '*%' : '*?';
57 sub expand_wildcards
58 {
59  @ARGV = map(/[$wild_regex]/o ? glob($_) : $_,@ARGV);
60 }
61
62
63 =item cat 
64
65 Concatenates all files mentioned on command line to STDOUT.
66
67 =cut 
68
69 sub cat ()
70 {
71  expand_wildcards();
72  print while (<>);
73 }
74
75 =item eqtime src dst
76
77 Sets modified time of dst to that of src
78
79 =cut 
80
81 sub eqtime
82 {
83  my ($src,$dst) = @ARGV;
84  local @ARGV = ($dst);  touch();  # in case $dst doesn't exist
85  utime((stat($src))[8,9],$dst);
86 }
87
88 =item rm_rf files....
89
90 Removes directories - recursively (even if readonly)
91
92 =cut 
93
94 sub rm_rf
95 {
96  expand_wildcards();
97  rmtree([grep -e $_,@ARGV],0,0);
98 }
99
100 =item rm_f files....
101
102 Removes files (even if readonly)
103
104 =cut 
105
106 sub rm_f {
107     expand_wildcards();
108
109     foreach my $file (@ARGV) {
110         next unless -f $file;
111
112         next if _unlink($file);
113
114         chmod(0777, $file);
115
116         next if _unlink($file);
117             
118         carp "Cannot delete $file: $!";
119     }
120 }
121
122 sub _unlink {
123     my $files_unlinked = 0;
124     foreach my $file (@_) {
125         my $delete_count = 0;
126         $delete_count++ while unlink $file;
127         $files_unlinked++ if $delete_count;
128     }
129     return $files_unlinked;
130 }
131
132
133 =item touch files ...
134
135 Makes files exist, with current timestamp 
136
137 =cut 
138
139 sub touch {
140     my $t    = time;
141     expand_wildcards();
142     foreach my $file (@ARGV) {
143         open(FILE,">>$file") || die "Cannot write $file:$!";
144         close(FILE);
145         utime($t,$t,$file);
146     }
147 }
148
149 =item mv source... destination
150
151 Moves source to destination.  Multiple sources are allowed if
152 destination is an existing directory.
153
154 Returns true if all moves succeeded, false otherwise.
155
156 =cut 
157
158 sub mv {
159     expand_wildcards();
160     my @src = @ARGV;
161     my $dst = pop @src;
162
163     croak("Too many arguments") if (@src > 1 && ! -d $dst);
164
165     my $nok = 0;
166     foreach my $src (@src) {
167         $nok ||= !move($src,$dst);
168     }
169     return !$nok;
170 }
171
172 =item cp source... destination
173
174 Copies source to destination.  Multiple sources are allowed if
175 destination is an existing directory.
176
177 Returns true if all copies succeeded, false otherwise.
178
179 =cut
180
181 sub cp {
182     expand_wildcards();
183     my @src = @ARGV;
184     my $dst = pop @src;
185
186     croak("Too many arguments") if (@src > 1 && ! -d $dst);
187
188     my $nok = 0;
189     foreach my $src (@src) {
190         $nok ||= !copy($src,$dst);
191     }
192     return $nok;
193 }
194
195 =item chmod mode files...
196
197 Sets UNIX like permissions 'mode' on all the files.  e.g. 0666
198
199 =cut 
200
201 sub chmod {
202     local @ARGV = @ARGV;
203     my $mode = shift(@ARGV);
204     expand_wildcards();
205
206     if( $Is_VMS ) {
207         foreach my $idx (0..$#ARGV) {
208             my $path = $ARGV[$idx];
209             next unless -d $path;
210
211             # chmod 0777, [.foo.bar] doesn't work on VMS, you have to do
212             # chmod 0777, [.foo]bar.dir
213             my @dirs = File::Spec->splitdir( $path );
214             $dirs[-1] .= '.dir';
215             $path = File::Spec->catfile(@dirs);
216
217             $ARGV[$idx] = $path;
218         }
219     }
220
221     chmod(oct $mode,@ARGV) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!";
222 }
223
224 =item mkpath directory...
225
226 Creates directory, including any parent directories.
227
228 =cut 
229
230 sub mkpath
231 {
232  expand_wildcards();
233  File::Path::mkpath([@ARGV],0,0777);
234 }
235
236 =item test_f file
237
238 Tests if a file exists
239
240 =cut 
241
242 sub test_f
243 {
244  exit !-f $ARGV[0];
245 }
246
247 =item dos2unix
248
249 Converts DOS and OS/2 linefeeds to Unix style recursively.
250
251 =cut
252
253 sub dos2unix {
254     require File::Find;
255     File::Find::find(sub {
256         return if -d;
257         return unless -w _;
258         return unless -r _;
259         return if -B _;
260
261         local $\;
262
263         my $orig = $_;
264         my $temp = '.dos2unix_tmp';
265         open ORIG, $_ or do { warn "dos2unix can't open $_: $!"; return };
266         open TEMP, ">$temp" or 
267             do { warn "dos2unix can't create .dos2unix_tmp: $!"; return };
268         while (my $line = <ORIG>) { 
269             $line =~ s/\015\012/\012/g;
270             print TEMP $line;
271         }
272         close ORIG;
273         close TEMP;
274         rename $temp, $orig;
275
276     }, @ARGV);
277 }
278
279 =back
280
281 =head1 BUGS
282
283 Should probably be Auto/Self loaded.
284
285 =head1 SEE ALSO 
286
287 ExtUtils::MakeMaker, ExtUtils::MM_Unix, ExtUtils::MM_Win32
288
289 =head1 AUTHOR
290
291 Nick Ing-Simmons C<ni-s@cpan.org>
292
293 Currently maintained by Michael G Schwern C<schwern@pobox.com>.
294
295 =cut
296