cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command.pm

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