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