Fix FindBin under Win32, and document success

private-msgid: 199704051504.QAA09507@ni-s.u-net.com
Signed-off-by: Nick Ing-Simmons <nik@tiuk.ti.com>

3 files changed, 127 insertions, 116 deletions

diff --git a/README.win32 b/README.win32
index 63763cd33d..0128469d88 100644
--- a/README.win32
+++ b/README.win32
@@ -138,25 +138,16 @@ PATH environment variable to C:\PERL\BIN (or D:\FOO\PERL\BIN).
 =head2 Testing
 
 Type "nmake test".  This will run most of the tests from the
-testsuite (many tests will be skipped, and a few tests may fail).
+testsuite (many tests will be skipped, and but no test should fail).
 
-To get a more detailed breakdown of the tests that failed, 
-you may want to say:
+If some tests do fail, it may be because you are using a different command
+shell than the native "cmd.exe".  To get a more detailed breakdown of the
+tests that failed, you may want to say:
 
        cd ..\t
        .\perl harness
 
-This should produce a summary of the failed tests.  Currently, the
-only known failure is lib\findbin.t:
-
-    Failed Test  Status Wstat Total Fail  Failed  List of failed
-    ------------------------------------------------------------------------------
-    lib/findbin.t                 1    1 100.00%  1
-    Failed 1/151 test scripts, 99.34% okay. 1/3902 subtests failed, 99.97% okay.
-
-
-Check if any additional tests other than the ones shown here
-failed, and report them as described under L<BUGS AND CAVEATS>.
+Please report any failures as described under L<BUGS AND CAVEATS>.
 
 =head1 BUGS AND CAVEATS
 
@@ -164,11 +155,11 @@ This is still very much an experimental port, and should be considered
 alpha quality software.  You can expect changes in virtually all of
 these areas: build process, installation structure, supported
 utilities/modules, and supported perl functionality.  Specifically,
-functionality that supports the Win32 environment may ultimately
+functionality specific to the Win32 environment may ultimately
 be supported as either core modules or extensions.
 
-If you have had prior exposure to Perl on Unix platforms, this port
-may exhibit behavior different from what is documented.  Most of the 
+If you have had prior exposure to Perl on Unix platforms, you will notice
+this port exhibits behavior different from what is documented.  Most of the
 differences fall under one of these categories.
 
 =over 8
@@ -264,7 +255,6 @@ at the time.
 Nick Ing-Simmons and Gurusamy Sarathy have made numerous and
 sundry hacks since then.
 
-Last updated: 04 April 1997
+Last updated: 05 April 1997
 
 =cut
-
diff --git a/lib/Cwd.pm b/lib/Cwd.pm
index f924a59647..e25ff4b223 100644
--- a/lib/Cwd.pm
+++ b/lib/Cwd.pm
@@ -1,6 +1,7 @@
 package Cwd;
 require 5.000;
 require Exporter;
+use Carp;
 
 =head1 NAME
 
@@ -45,15 +46,16 @@ kept up to date if all packages which use chdir import it from Cwd.
 
 @ISA = qw(Exporter);
 @EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
-@EXPORT_OK = qw(chdir);
+@EXPORT_OK = qw(chdir abs_path fast_abspath);
 
 # use strict;
 
-sub _backtick_pwd {  # The 'natural and safe form' for UNIX (pwd may be setuid root)
+# The 'natural and safe form' for UNIX (pwd may be setuid root)
+sub _backtick_pwd {
     my $cwd;
     chop($cwd = `pwd`);
     $cwd;
-} 
+}
 
 # Since some ports may predefine cwd internally (e.g., NT)
 # we take care not to override an existing definition for cwd().
@@ -216,14 +218,81 @@ sub chdir {
     1;
 }
 
+# Taken from Cwd.pm It is really getcwd with an optional
+# parameter instead of '.'
+#
+
+sub abs_path
+{
+    my $start = shift || '.';
+    my($dotdots, $cwd, @pst, @cst, $dir, @tst);
+
+    unless (@cst = stat( $start ))
+    {
+	carp "stat($start): $!";
+	return '';
+    }
+    $cwd = '';
+    $dotdots = $start;
+    do
+    {
+	$dotdots .= '/..';
+	@pst = @cst;
+	unless (opendir(PARENT, $dotdots))
+	{
+	    carp "opendir($dotdots): $!";
+	    return '';
+	}
+	unless (@cst = stat($dotdots))
+	{
+	    carp "stat($dotdots): $!";
+	    closedir(PARENT);
+	    return '';
+	}
+	if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
+	{
+	    $dir = '';
+	}
+	else
+	{
+	    do
+	    {
+		unless (defined ($dir = readdir(PARENT)))
+	        {
+		    carp "readdir($dotdots): $!";
+		    closedir(PARENT);
+		    return '';
+		}
+		$tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
+	    }
+	    while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
+		   $tst[1] != $pst[1]);
+	}
+	$cwd = "$dir/$cwd";
+	closedir(PARENT);
+    } while ($dir);
+    chop($cwd); # drop the trailing /
+    $cwd;
+}
+
+sub fast_abspath
+{
+ my $cwd = getcwd();
+ my $path = shift || '.';
+ chdir($path) || croak "Cannot chdir to $path:$!";
+ my $realpath = getcwd();
+ chdir($cwd)  || croak "Cannot chdir back to $cwd:$!";
+ $realpath;
+}
+
 
 # --- PORTING SECTION ---
 
 # VMS: $ENV{'DEFAULT'} points to default directory at all times
 # 06-Mar-1996  Charles Bailey  bailey@genetics.upenn.edu
 # Note: Use of Cwd::chdir() causes the logical name PWD to be defined
-#   in the process logical name table as the default device and directory 
-#   seen by Perl. This may not be the same as the default device 
+#   in the process logical name table as the default device and directory
+#   seen by Perl. This may not be the same as the default device
 #   and directory seen by DCL after Perl exits, since the effects
 #   the CRTL chdir() function persist only until Perl exits.
 
@@ -238,7 +307,7 @@ sub _os2_cwd {
     return $ENV{'PWD'};
 }
 
-*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
+*_NT_cwd     = \&_os2_cwd unless defined &_NT_cwd;
 
 sub _msdos_cwd {
     $ENV{'PWD'} = `command /c cd`;
@@ -255,13 +324,15 @@ sub _msdos_cwd {
         *getcwd     = \&_vms_cwd;
         *fastcwd    = \&_vms_cwd;
         *fastgetcwd = \&_vms_cwd;
+        *abs_path	= \&fast_abspath;
     }
     elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
         # We assume that &_NT_cwd is defined as an XSUB or in the core.
-        *cwd        = \&_NT_cwd;
-        *getcwd     = \&_NT_cwd;
-        *fastcwd    = \&_NT_cwd;
-        *fastgetcwd = \&_NT_cwd;
+        *cwd         = \&_NT_cwd;
+        *getcwd      = \&_NT_cwd;
+        *fastcwd     = \&_NT_cwd;
+        *fastgetcwd  = \&_NT_cwd;
+        *abs_path    = \&fast_abspath;
     }
     elsif ($^O eq 'os2') {
         # sys_cwd may keep the builtin command
@@ -269,12 +340,14 @@ sub _msdos_cwd {
         *getcwd	 = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
         *fastgetcwd	 = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
         *fastcwd	 = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
+        *abs_path	= \&fast_abspath;
     }
     elsif ($^O eq 'msdos') {
         *cwd     = \&_msdos_cwd;
         *getcwd     = \&_msdos_cwd;
         *fastgetcwd = \&_msdos_cwd;
         *fastcwd = \&_msdos_cwd;
+        *abs_path	= \&fast_abspath;
     }
 }
 
diff --git a/lib/FindBin.pm b/lib/FindBin.pm
index bbd72a2aa2..d908121ded 100644
--- a/lib/FindBin.pm
+++ b/lib/FindBin.pm
@@ -13,7 +13,7 @@ FindBin - Locate directory of original perl script
  use FindBin;
  use lib "$FindBin::Bin/../lib";
 
- or 
+ or
 
  use FindBin qw($Bin);
  use lib "$Bin/../lib";
@@ -74,7 +74,9 @@ package FindBin;
 use Carp;
 require 5.000;
 require Exporter;
-use Cwd qw(getcwd);
+use Cwd qw(getcwd abs_path);
+use Config;
+use File::Basename;
 
 @EXPORT_OK = qw($Bin $Script $RealBin $RealScript $Dir $RealDir);
 %EXPORT_TAGS = (ALL => [qw($Bin $Script $RealBin $RealScript $Dir $RealDir)]);
@@ -82,80 +84,23 @@ use Cwd qw(getcwd);
 
 $VERSION = $VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/);
 
-# Taken from Cwd.pm It is really getcwd with an optional
-# parameter instead of '.'
-#
-# another way would be:
-#
-#sub abs_path
-#{
-# my $cwd = getcwd();
-# chdir(shift || '.');
-# my $realpath = getcwd();
-# chdir($cwd);
-# $realpath;
-#}
-
-sub my_abs_path
+sub is_abs_path
 {
-    my $start = shift || '.';
-    my($dotdots, $cwd, @pst, @cst, $dir, @tst);
-
-    unless (@cst = stat( $start ))
-    {
-	warn "stat($start): $!";
-	return '';
-    }
-    $cwd = '';
-    $dotdots = $start;
-    do
-    {
-	$dotdots .= '/..';
-	@pst = @cst;
-	unless (opendir(PARENT, $dotdots))
-	{
-	    warn "opendir($dotdots): $!";
-	    return '';
-	}
-	unless (@cst = stat($dotdots))
-	{
-	    warn "stat($dotdots): $!";
-	    closedir(PARENT);
-	    return '';
-	}
-	if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
-	{
-	    $dir = '';
-	}
-	else
-	{
-	    do
-	    {
-		unless (defined ($dir = readdir(PARENT)))
-	        {
-		    warn "readdir($dotdots): $!";
-		    closedir(PARENT);
-		    return '';
-		}
-		$tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
-	    }
-	    while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
-		   $tst[1] != $pst[1]);
-	}
-	$cwd = "$dir/$cwd";
-	closedir(PARENT);
-    } while ($dir);
-    chop($cwd); # drop the trailing /
-    $cwd;
+ local $_ = shift if (@_);
+ if ($^O eq 'MSWin32')
+  {
+   return m#^[a-z]:[\\/]#i;
+  }
+ else
+  {
+   return m#^/#;
+  }
 }
 
-
 BEGIN
 {
  *Dir = \$Bin;
  *RealDir = \$RealBin;
- if (defined &Cwd::sys_abspath) { *abs_path = \&Cwd::sys_abspath}
- else { *abs_path = \&my_abs_path}
 
  if($0 eq '-e' || $0 eq '-')
   {
@@ -175,17 +120,20 @@ BEGIN
     }
    else
     {
-     unless($script =~ m#/# && -f $script)
+     my $IsWin32 = $^O eq 'MSWin32';
+     unless(($script =~ m#/# || ($IsWin32 && $script =~ m#\\#))
+            && -f $script)
       {
        my $dir;
-       
-       foreach $dir (split(/:/,$ENV{PATH}))
+       my $pathvar = ($IsWin32) ? 'Path' : 'PATH';
+
+       foreach $dir (split(/$Config{'path_sep'}/,$ENV{$pathvar}))
 	{
-	if(-x "$dir/$script")
+	if(-r "$dir/$script" && (!$IsWin32 || -x _))
          {
           $script = "$dir/$script";
-   
-	  if (-f $0) 
+
+	  if (-f $0)
            {
 	    # $script has been found via PATH but perl could have
 	    # been invoked as 'perl file'. Do a dumb check to see
@@ -194,31 +142,31 @@ BEGIN
             # well we actually only check that it is an ASCII file
             # we know its executable so it is probably a script
             # of some sort.
-   
+
             $script = $0 unless(-T $script);
            }
           last;
          }
        }
      }
-  
+
      croak("Cannot find current script '$0'") unless(-f $script);
-  
+
      # Ensure $script contains the complete path incase we C<chdir>
-  
-     $script = getcwd() . "/" . $script unless($script =~ m,^/,);
-   
-     ($Bin,$Script) = $script =~ m,^(.*?)/+([^/]+)$,;
-  
+
+     $script = getcwd() . "/" . $script unless is_abs_path($script);
+
+     ($Script,$Bin) = fileparse($script);
+
      # Resolve $script if it is a link
      while(1)
       {
        my $linktext = readlink($script);
-  
-       ($RealBin,$RealScript) = $script =~ m,^(.*?)/+([^/]+)$,;
+
+       ($RealScript,$RealBin) = fileparse($script);
        last unless defined $linktext;
-  
-       $script = ($linktext =~ m,^/,)
+
+       $script = (is_abs_path($linktext))
                   ? $linktext
                   : $RealBin . "/" . $linktext;
       }