From: Nick Ing-Simmons Date: Sat, 5 Apr 1997 15:04:52 +0000 (+0100) Subject: Fix FindBin under Win32, and document success X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8b88ae9267370552321fe1d45306b5341068d1e2;p=p5sagit%2Fp5-mst-13.2.git Fix FindBin under Win32, and document success private-msgid: 199704051504.QAA09507@ni-s.u-net.com Signed-off-by: Nick Ing-Simmons --- diff --git a/README.win32 b/README.win32 index 63763cd..0128469 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. +Please report any failures as described under L. =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 f924a59..e25ff4b 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 bbd72a2..d908121 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 - - $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; }