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