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