This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix FindBin under Win32, and document success
authorNick Ing-Simmons <nik@tiuk.ti.com>
Sat, 5 Apr 1997 15:04:52 +0000 (16:04 +0100)
committerChip Salzenberg <chip@atlantic.net>
Fri, 4 Apr 1997 00:00:00 +0000 (00:00 +0000)
private-msgid: 199704051504.QAA09507@ni-s.u-net.com
Signed-off-by: Nick Ing-Simmons <nik@tiuk.ti.com>
README.win32
lib/Cwd.pm
lib/FindBin.pm

index 63763cd..0128469 100644 (file)
@@ -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
-
index f924a59..e25ff4b 100644 (file)
@@ -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;
     }
 }
 
index bbd72a2..d908121 100644 (file)
@@ -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;
       }