X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FFindBin.pm;h=918775cda7fcb78663018bf0080eab6a0e02a2ae;hb=b6d5cd8ca8d16f83d5c4c7a0bc602634e3efb321;hp=4bfc098f1e5d225a4e33023505bba7aa95094ba6;hpb=84dc3c4daae48410e767ac41da148ac5c6c45446;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/FindBin.pm b/lib/FindBin.pm
index 4bfc098..918775c 100644
--- a/lib/FindBin.pm
+++ b/lib/FindBin.pm
@@ -11,12 +11,12 @@ FindBin - Locate directory of original perl script
 =head1 SYNOPSIS
 
  use FindBin;
- BEGIN { unshift(@INC,"$FindBin::Bin/../lib") }
+ use lib "$FindBin::Bin/../lib";
 
- or 
+ or
 
  use FindBin qw($Bin);
- BEGIN { unshift(@INC,"$Bin/../lib") }
+ use lib "$Bin/../lib";
 
 =head1 DESCRIPTION
 
@@ -24,7 +24,7 @@ Locates the full path to the script bin directory to allow the use
 of paths relative to the bin directory.
 
 This allows a user to setup a directory tree for some software with
-directories <root>/bin and <root>/lib and then the above example will allow
+directories E<lt>rootE<gt>/bin and E<lt>rootE<gt>/lib and then the above example will allow
 the use of modules in the lib directory without knowing where the software
 tree is installed.
 
@@ -55,8 +55,8 @@ Workaround is to invoke perl as
 
 =head1 AUTHORS
 
-Graham Barr <bodg@tiuk.ti.com>
-Nick Ing-Simmons <nik@tiuk.ti.com>
+Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>
+Nick Ing-Simmons E<lt>F<nik@tiuk.ti.com>E<gt>
 
 =head1 COPYRIGHT
 
@@ -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,74 +84,25 @@ 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 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;
+  }
+ elsif ($^O eq 'VMS')
+  {
+    # If it's a logical name, expand it.
+    $_ = $ENV{$_} while /^[\w\$\-]+$/ and $ENV{$_};
+    return m!^/! or m![<\[][^.\-\]>]! or /:[^<\[]/;
+  }
+ else
+  {
+   return m#^/#;
+  }
 }
 
-
 BEGIN
 {
  *Dir = \$Bin;
@@ -173,17 +126,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
@@ -192,31 +148,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;
       }