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