X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FFindBin.pm;h=0d75414a33c1f09be650593970d6bde0a6d6ba3b;hb=46471bde41ad0777edf7b89818df6730e8b55c20;hp=ecfa3005b22ed8b86074de5f8a6b19e760adb503;hpb=a73990fdb7aa812be91abe65dea1c0c2af4eb8ed;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/FindBin.pm b/lib/FindBin.pm index ecfa300..0d75414 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 -the use of modules in the lib directory without knowing where the software -tree is installed. +directories C<< /bin >> and C<< /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,15 +39,36 @@ 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 a +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. To make sure that C will work is to call the C +function: + + use FindBin; + FindBin::again(); # or FindBin->again; + +In former versions of FindBin there was no C function. The +workaround was 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 -assumes that it was invoked via the C<$ENV{PATH}>. +and I does not have executable rights and a program called +I 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 +76,12 @@ 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,93 +89,32 @@ 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 cwd 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+)/); +$VERSION = "1.48"; -# 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; +sub cwd2 { + my $cwd = getcwd(); + # getcwd might fail if it hasn't access to the current directory. + # try harder. + defined $cwd or $cwd = cwd(); + $cwd; } - -BEGIN +sub init { *Dir = \$Bin; *RealDir = \$RealBin; @@ -158,9 +122,8 @@ BEGIN if($0 eq '-e' || $0 eq '-') { # perl invoked with -e or script is on C - $Script = $RealScript = $0; - $Bin = $RealBin = getcwd(); + $Bin = $RealBin = cwd2(); } else { @@ -168,65 +131,70 @@ 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})) - { - if(-x "$dir/$script") + foreach $dir (File::Spec->path) + { + my $scr = File::Spec->catfile($dir, $script); + + # $script can been found via PATH but perl could have + # been invoked as 'perl file'. Do a dumb check to see + # if $script is a perl program, if not then keep $script = $0 + # + # well we actually only check that it is an ASCII file + # we know its executable so it is probably a script + # of some sort. + if(-f $scr && -r _ && ($dosish || -x _) && -s _ && -T _) { - $script = "$dir/$script"; - - if (-f $0) - { - # $script has been found via PATH but perl could have - # been invoked as 'perl file'. Do a dumb check to see - # if $script is a perl program, if not then $script = $0 - # - # 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); - } + $script = $scr; 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,^(.*?)/+([^/]+)$,; - + + # Ensure $script contains the complete path in case we C + + $script = File::Spec->catfile(cwd2(), $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 - $Bin = abs_path($Bin) if($Bin); + if ($Bin) { + my $BinOld = $Bin; + $Bin = abs_path($Bin); + defined $Bin or $Bin = File::Spec->canonpath($BinOld); + } $RealBin = abs_path($RealBin) if($RealBin); } } } -1; # Keep require happy +BEGIN { init } + +*again = \&init; +1; # Keep require happy