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