Fix RT69056 - postive GPOS leads to segv on first match

[p5sagit/p5-mst-13.2.git] / lib / ExtUtils / Command.pm

diff --git a/lib/ExtUtils/Command.pm b/lib/ExtUtils/Command.pm
index ecd7813..b5632ff 100644 (file)
--- a/lib/ExtUtils/Command.pm
+++ b/lib/ExtUtils/Command.pm
@@ -10,11 +10,36 @@ use File::Path qw(rmtree);
 require Exporter;
 use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
 @ISA       = qw(Exporter);
-@EXPORT    = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f chmod 
+@EXPORT    = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod
                 dos2unix);
-$VERSION = '1.09';
+$VERSION = '1.16';
+
+my $Is_VMS   = $^O eq 'VMS';
+my $Is_VMS_mode = $Is_VMS;
+my $Is_VMS_noefs = $Is_VMS;
+my $Is_Win32 = $^O eq 'MSWin32';
+
+if( $Is_VMS ) {
+    my $vms_unix_rpt;
+    my $vms_efs;
+    my $vms_case;
+
+    if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
+        $vms_unix_rpt = VMS::Feature::current("filename_unix_report");
+        $vms_efs = VMS::Feature::current("efs_charset");
+        $vms_case = VMS::Feature::current("efs_case_preserve");
+    } else {
+        my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
+        my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || '';
+        my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || '';
+        $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; 
+        $vms_efs = $efs_charset =~ /^[ET1]/i;
+        $vms_case = $efs_case =~ /^[ET1]/i;
+    }
+    $Is_VMS_mode = 0 if $vms_unix_rpt;
+    $Is_VMS_noefs = 0 if ($vms_efs);
+}
 
-my $Is_VMS = $^O eq 'VMS';
 
 =head1 NAME
 
@@ -22,27 +47,28 @@ ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc.
 
 =head1 SYNOPSIS
 
-  perl -MExtUtils::Command  -e cat files... > destination
-  perl -MExtUtils::Command  -e mv source... destination
-  perl -MExtUtils::Command  -e cp source... destination
-  perl -MExtUtils::Command  -e touch files...
-  perl -MExtUtils::Command  -e rm_f files...
-  perl -MExtUtils::Command  -e rm_rf directories...
-  perl -MExtUtils::Command  -e mkpath directories...
-  perl -MExtUtils::Command  -e eqtime source destination
-  perl -MExtUtils::Command  -e test_f file
-  perl -MExtUtils::Command  -e chmod mode files...
+  perl -MExtUtils::Command -e cat files... > destination
+  perl -MExtUtils::Command -e mv source... destination
+  perl -MExtUtils::Command -e cp source... destination
+  perl -MExtUtils::Command -e touch files...
+  perl -MExtUtils::Command -e rm_f files...
+  perl -MExtUtils::Command -e rm_rf directories...
+  perl -MExtUtils::Command -e mkpath directories...
+  perl -MExtUtils::Command -e eqtime source destination
+  perl -MExtUtils::Command -e test_f file
+  perl -MExtUtils::Command -e test_d directory
+  perl -MExtUtils::Command -e chmod mode files...
   ...
 
 =head1 DESCRIPTION
 
 The module is used to replace common UNIX commands.  In all cases the
 functions work from @ARGV rather than taking arguments.  This makes
-them easier to deal with in Makefiles.
+them easier to deal with in Makefiles.  Call them like this:
 
   perl -MExtUtils::Command -e some_command some files to work on
 
-I<NOT>
+and I<NOT> like this:
 
   perl -MExtUtils::Command -e 'some_command qw(some files to work on)'
 
@@ -50,6 +76,9 @@ For that use L<Shell::Command>.
 
 Filenames with * and ? will be glob expanded.
 
+
+=head2 FUNCTIONS
+
 =over 4
 
 =cut
@@ -206,6 +235,10 @@ sub cp {
     my $nok = 0;
     foreach my $src (@src) {
         $nok ||= !copy($src,$dst);
+
+        # Win32 does not update the mod time of a copied file, just the
+        # created time which make does not look at.
+        utime(time, time, $dst) if $Is_Win32;
     }
     return $nok;
 }
@@ -223,7 +256,7 @@ sub chmod {
     my $mode = shift(@ARGV);
     expand_wildcards();
 
-    if( $Is_VMS ) {
+    if( $Is_VMS_mode && $Is_VMS_noefs) {
         foreach my $idx (0..$#ARGV) {
             my $path = $ARGV[$idx];
             next unless -d $path;
@@ -259,13 +292,28 @@ sub mkpath
 
     test_f file
 
-Tests if a file exists
+Tests if a file exists.  I<Exits> with 0 if it does, 1 if it does not (ie.
+shell's idea of true and false).
 
 =cut 
 
 sub test_f
 {
- exit !-f $ARGV[0];
+ exit(-f $ARGV[0] ? 0 : 1);
+}
+
+=item test_d
+
+    test_d directory
+
+Tests if a directory exists.  I<Exits> with 0 if it does, 1 if it does
+not (ie. shell's idea of true and false).
+
+=cut
+
+sub test_d
+{
+ exit(-d $ARGV[0] ? 0 : 1);
 }
 
 =item dos2unix
@@ -304,7 +352,7 @@ sub dos2unix {
 
 =back
 
-=head1 SEE ALSO 
+=head1 SEE ALSO
 
 Shell::Command which is these same functions but take arguments normally.
 
@@ -313,7 +361,9 @@ Shell::Command which is these same functions but take arguments normally.
 
 Nick Ing-Simmons C<ni-s@cpan.org>
 
-Currently maintained by Michael G Schwern C<schwern@pobox.com>.
+Maintained by Michael G Schwern C<schwern@pobox.com> within the
+ExtUtils-MakeMaker package and, as a separate CPAN package, by
+Randy Kobes C<r.kobes@uwinnipeg.ca>.
 
 =cut