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