Commit | Line | Data |
---|---|---|
a73990fd | 1 | # FindBin.pm |
2 | # | |
3 | # Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved. | |
4 | # This program is free software; you can redistribute it and/or modify it | |
5 | # under the same terms as Perl itself. | |
6 | ||
7 | =head1 NAME | |
8 | ||
9 | FindBin - Locate directory of original perl script | |
10 | ||
11 | =head1 SYNOPSIS | |
12 | ||
13 | use FindBin; | |
d7791a84 | 14 | use lib "$FindBin::Bin/../lib"; |
a73990fd | 15 | |
16 | or | |
17 | ||
18 | use FindBin qw($Bin); | |
d7791a84 | 19 | use lib "$Bin/../lib"; |
a73990fd | 20 | |
21 | =head1 DESCRIPTION | |
22 | ||
23 | Locates the full path to the script bin directory to allow the use | |
24 | of paths relative to the bin directory. | |
25 | ||
26 | This allows a user to setup a directory tree for some software with | |
1fef88e7 | 27 | directories E<lt>rootE<gt>/bin and E<lt>rootE<gt>/lib and then the above example will allow |
a73990fd | 28 | the use of modules in the lib directory without knowing where the software |
29 | tree is installed. | |
30 | ||
84dc3c4d | 31 | If perl is invoked using the B<-e> option or the perl script is read from |
a73990fd | 32 | C<STDIN> then FindBin sets both C<$Bin> and C<$RealBin> to the current |
33 | directory. | |
34 | ||
35 | =head1 EXPORTABLE VARIABLES | |
36 | ||
37 | $Bin - path to bin directory from where script was invoked | |
38 | $Script - basename of script from which perl was invoked | |
39 | $RealBin - $Bin with all links resolved | |
40 | $RealScript - $Script with all links resolved | |
41 | ||
42 | =head1 KNOWN BUGS | |
43 | ||
44 | if perl is invoked as | |
45 | ||
46 | perl filename | |
47 | ||
48 | and I<filename> does not have executable rights and a program called I<filename> | |
84dc3c4d | 49 | exists in the users C<$ENV{PATH}> which satisfies both B<-x> and B<-T> then FindBin |
a73990fd | 50 | assumes that it was invoked via the C<$ENV{PATH}>. |
51 | ||
52 | Workaround is to invoke perl as | |
53 | ||
54 | perl ./filename | |
55 | ||
56 | =head1 AUTHORS | |
57 | ||
1fef88e7 JM |
58 | Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt> |
59 | Nick Ing-Simmons E<lt>F<nik@tiuk.ti.com>E<gt> | |
a73990fd | 60 | |
61 | =head1 COPYRIGHT | |
62 | ||
63 | Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved. | |
64 | This program is free software; you can redistribute it and/or modify it | |
65 | under the same terms as Perl itself. | |
66 | ||
67 | =head1 REVISION | |
68 | ||
69 | $Revision: 1.4 $ | |
70 | ||
71 | =cut | |
72 | ||
73 | package FindBin; | |
74 | use Carp; | |
75 | require 5.000; | |
76 | require Exporter; | |
77 | use Cwd qw(getcwd); | |
78 | ||
79 | @EXPORT_OK = qw($Bin $Script $RealBin $RealScript $Dir $RealDir); | |
80 | %EXPORT_TAGS = (ALL => [qw($Bin $Script $RealBin $RealScript $Dir $RealDir)]); | |
81 | @ISA = qw(Exporter); | |
82 | ||
83 | $VERSION = $VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/); | |
84 | ||
85 | # Taken from Cwd.pm It is really getcwd with an optional | |
86 | # parameter instead of '.' | |
87 | # | |
88 | # another way would be: | |
89 | # | |
90 | #sub abs_path | |
91 | #{ | |
92 | # my $cwd = getcwd(); | |
93 | # chdir(shift || '.'); | |
94 | # my $realpath = getcwd(); | |
95 | # chdir($cwd); | |
96 | # $realpath; | |
97 | #} | |
98 | ||
55497cff | 99 | sub my_abs_path |
a73990fd | 100 | { |
101 | my $start = shift || '.'; | |
102 | my($dotdots, $cwd, @pst, @cst, $dir, @tst); | |
103 | ||
104 | unless (@cst = stat( $start )) | |
105 | { | |
106 | warn "stat($start): $!"; | |
107 | return ''; | |
108 | } | |
109 | $cwd = ''; | |
110 | $dotdots = $start; | |
111 | do | |
112 | { | |
113 | $dotdots .= '/..'; | |
114 | @pst = @cst; | |
115 | unless (opendir(PARENT, $dotdots)) | |
116 | { | |
117 | warn "opendir($dotdots): $!"; | |
118 | return ''; | |
119 | } | |
120 | unless (@cst = stat($dotdots)) | |
121 | { | |
122 | warn "stat($dotdots): $!"; | |
123 | closedir(PARENT); | |
124 | return ''; | |
125 | } | |
126 | if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) | |
127 | { | |
128 | $dir = ''; | |
129 | } | |
130 | else | |
131 | { | |
132 | do | |
133 | { | |
134 | unless (defined ($dir = readdir(PARENT))) | |
135 | { | |
136 | warn "readdir($dotdots): $!"; | |
137 | closedir(PARENT); | |
138 | return ''; | |
139 | } | |
140 | $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir")) | |
141 | } | |
142 | while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || | |
143 | $tst[1] != $pst[1]); | |
144 | } | |
145 | $cwd = "$dir/$cwd"; | |
146 | closedir(PARENT); | |
147 | } while ($dir); | |
148 | chop($cwd); # drop the trailing / | |
149 | $cwd; | |
150 | } | |
151 | ||
152 | ||
153 | BEGIN | |
154 | { | |
155 | *Dir = \$Bin; | |
156 | *RealDir = \$RealBin; | |
55497cff | 157 | if (defined &Cwd::sys_abspath) { *abs_path = \&Cwd::sys_abspath} |
158 | else { *abs_path = \&my_abs_path} | |
a73990fd | 159 | |
160 | if($0 eq '-e' || $0 eq '-') | |
161 | { | |
162 | # perl invoked with -e or script is on C<STDIN> | |
163 | ||
164 | $Script = $RealScript = $0; | |
165 | $Bin = $RealBin = getcwd(); | |
166 | } | |
167 | else | |
168 | { | |
169 | my $script = $0; | |
170 | ||
171 | if ($^O eq 'VMS') | |
172 | { | |
173 | ($Bin,$Script) = VMS::Filespec::rmsexpand($0) =~ /(.*\])(.*)/; | |
174 | ($RealBin,$RealScript) = ($Bin,$Script); | |
175 | } | |
176 | else | |
177 | { | |
178 | unless($script =~ m#/# && -f $script) | |
179 | { | |
180 | my $dir; | |
181 | ||
182 | foreach $dir (split(/:/,$ENV{PATH})) | |
183 | { | |
184 | if(-x "$dir/$script") | |
185 | { | |
186 | $script = "$dir/$script"; | |
187 | ||
188 | if (-f $0) | |
189 | { | |
190 | # $script has been found via PATH but perl could have | |
191 | # been invoked as 'perl file'. Do a dumb check to see | |
192 | # if $script is a perl program, if not then $script = $0 | |
193 | # | |
194 | # well we actually only check that it is an ASCII file | |
195 | # we know its executable so it is probably a script | |
196 | # of some sort. | |
197 | ||
198 | $script = $0 unless(-T $script); | |
199 | } | |
200 | last; | |
201 | } | |
202 | } | |
203 | } | |
204 | ||
205 | croak("Cannot find current script '$0'") unless(-f $script); | |
206 | ||
207 | # Ensure $script contains the complete path incase we C<chdir> | |
208 | ||
209 | $script = getcwd() . "/" . $script unless($script =~ m,^/,); | |
210 | ||
211 | ($Bin,$Script) = $script =~ m,^(.*?)/+([^/]+)$,; | |
212 | ||
213 | # Resolve $script if it is a link | |
214 | while(1) | |
215 | { | |
216 | my $linktext = readlink($script); | |
217 | ||
218 | ($RealBin,$RealScript) = $script =~ m,^(.*?)/+([^/]+)$,; | |
219 | last unless defined $linktext; | |
220 | ||
221 | $script = ($linktext =~ m,^/,) | |
222 | ? $linktext | |
223 | : $RealBin . "/" . $linktext; | |
224 | } | |
225 | ||
226 | # Get absolute paths to directories | |
227 | $Bin = abs_path($Bin) if($Bin); | |
228 | $RealBin = abs_path($RealBin) if($RealBin); | |
229 | } | |
230 | } | |
231 | } | |
232 | ||
233 | 1; # Keep require happy | |
234 |