[Summary view] [Print] [Text view]

   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