X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FFindBin.pm;h=8be9cb6b5af0659ab0bc41728de7e248e536199a;hb=6d5637c3050c14fb5c11ec5a05db33dce9e4a7a8;hp=ecfa3005b22ed8b86074de5f8a6b19e760adb503;hpb=a73990fdb7aa812be91abe65dea1c0c2af4eb8ed;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/FindBin.pm b/lib/FindBin.pm index ecfa300..8be9cb6 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,11 +24,11 @@ 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 /bin and /lib and then the above example will allow +directories ErootE/bin and ErootE/lib and then the above example will allow the use of modules in the lib directory without knowing where the software tree is installed. -If perl is invoked using the -e option or the perl script is read from +If perl is invoked using the B<-e> option or the perl script is read from C then FindBin sets both C<$Bin> and C<$RealBin> to the current directory. @@ -39,14 +39,28 @@ directory. $RealBin - $Bin with all links resolved $RealScript - $Script with all links resolved +=head1 KNOWN ISSUES + +If there are two modules using C from different directories +under the same interpreter, this won't work. Since C uses +C block, it'll be executed only once, and only the first caller +will get it right. This is a problem under mod_perl and other persistent +Perl environments, where you shouldn't use this module. Which also means +that you should avoid using C in modules that you plan to put +on CPAN. The only way to make sure that C will work is to force +the C block to be executed again: + + delete $INC{'FindBin.pm'}; + require FindBin; + =head1 KNOWN BUGS -if perl is invoked as +If perl is invoked as perl filename and I does not have executable rights and a program called I -exists in the users C<$ENV{PATH}> which satisfies both -x and -T then FindBin +exists in the users C<$ENV{PATH}> which satisfies both B<-x> and B<-T> then FindBin assumes that it was invoked via the C<$ENV{PATH}>. Workaround is to invoke perl as @@ -55,8 +69,11 @@ Workaround is to invoke perl as =head1 AUTHORS -Graham Barr -Nick Ing-Simmons +FindBin is supported as part of the core perl distribution. Please send bug +reports to EFE using the perlbug program included with perl. + +Graham Barr EFE +Nick Ing-Simmons EFE =head1 COPYRIGHT @@ -64,91 +81,22 @@ Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=head1 REVISION - -$Revision: 1.4 $ - =cut package FindBin; use Carp; require 5.000; require Exporter; -use Cwd qw(getcwd); +use Cwd qw(getcwd abs_path); +use Config; +use File::Basename; +use File::Spec; @EXPORT_OK = qw($Bin $Script $RealBin $RealScript $Dir $RealDir); %EXPORT_TAGS = (ALL => [qw($Bin $Script $RealBin $RealScript $Dir $RealDir)]); @ISA = qw(Exporter); -$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 -{ - 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; -} - +$VERSION = "1.43"; BEGIN { @@ -168,22 +116,24 @@ BEGIN if ($^O eq 'VMS') { - ($Bin,$Script) = VMS::Filespec::rmsexpand($0) =~ /(.*\])(.*)/; + ($Bin,$Script) = VMS::Filespec::rmsexpand($0) =~ /(.*\])(.*)/s; ($RealBin,$RealScript) = ($Bin,$Script); } else { - unless($script =~ m#/# && -f $script) + my $dosish = ($^O eq 'MSWin32' or $^O eq 'os2'); + unless(($script =~ m#/# || ($dosish && $script =~ m#\\#)) + && -f $script) { my $dir; - - foreach $dir (split(/:/,$ENV{PATH})) + foreach $dir (File::Spec->path) { - if(-x "$dir/$script") + my $scr = File::Spec->catfile($dir, $script); + if(-r $scr && (!$dosish || -x _)) { - $script = "$dir/$script"; - - if (-f $0) + $script = $scr; + + 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,33 +142,34 @@ 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 = File::Spec->catfile(getcwd(), $script) + unless File::Spec->file_name_is_absolute($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 = (File::Spec->file_name_is_absolute($linktext)) ? $linktext - : $RealBin . "/" . $linktext; + : File::Spec->catfile($RealBin, $linktext); } # Get absolute paths to directories