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