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