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 |
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 | |
99 | sub abs_path |
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; |
157 | |
158 | if($0 eq '-e' || $0 eq '-') |
159 | { |
160 | # perl invoked with -e or script is on C<STDIN> |
161 | |
162 | $Script = $RealScript = $0; |
163 | $Bin = $RealBin = getcwd(); |
164 | } |
165 | else |
166 | { |
167 | my $script = $0; |
168 | |
169 | if ($^O eq 'VMS') |
170 | { |
171 | ($Bin,$Script) = VMS::Filespec::rmsexpand($0) =~ /(.*\])(.*)/; |
172 | ($RealBin,$RealScript) = ($Bin,$Script); |
173 | } |
174 | else |
175 | { |
176 | unless($script =~ m#/# && -f $script) |
177 | { |
178 | my $dir; |
179 | |
180 | foreach $dir (split(/:/,$ENV{PATH})) |
181 | { |
182 | if(-x "$dir/$script") |
183 | { |
184 | $script = "$dir/$script"; |
185 | |
186 | if (-f $0) |
187 | { |
188 | # $script has been found via PATH but perl could have |
189 | # been invoked as 'perl file'. Do a dumb check to see |
190 | # if $script is a perl program, if not then $script = $0 |
191 | # |
192 | # well we actually only check that it is an ASCII file |
193 | # we know its executable so it is probably a script |
194 | # of some sort. |
195 | |
196 | $script = $0 unless(-T $script); |
197 | } |
198 | last; |
199 | } |
200 | } |
201 | } |
202 | |
203 | croak("Cannot find current script '$0'") unless(-f $script); |
204 | |
205 | # Ensure $script contains the complete path incase we C<chdir> |
206 | |
207 | $script = getcwd() . "/" . $script unless($script =~ m,^/,); |
208 | |
209 | ($Bin,$Script) = $script =~ m,^(.*?)/+([^/]+)$,; |
210 | |
211 | # Resolve $script if it is a link |
212 | while(1) |
213 | { |
214 | my $linktext = readlink($script); |
215 | |
216 | ($RealBin,$RealScript) = $script =~ m,^(.*?)/+([^/]+)$,; |
217 | last unless defined $linktext; |
218 | |
219 | $script = ($linktext =~ m,^/,) |
220 | ? $linktext |
221 | : $RealBin . "/" . $linktext; |
222 | } |
223 | |
224 | # Get absolute paths to directories |
225 | $Bin = abs_path($Bin) if($Bin); |
226 | $RealBin = abs_path($RealBin) if($RealBin); |
227 | } |
228 | } |
229 | } |
230 | |
231 | 1; # Keep require happy |
232 | |