File Coverage

blib/lib/FindBin/libs.pm
Criterion Covered Total %
statement 46 58 79.3
branch 12 26 46.1
condition 2 5 40.0
subroutine 10 10 100.0
pod n/a
total 70 99 70.7


line stmt bran cond sub pod time code
1             ########################################################################
2             # housekeeping
3             ########################################################################
4              
5             package FindBin::libs v2.12.01;
6 10     10   126381 use v5.14;
  10         57  
7 10     10   46 use strict;
  10         23  
  10         269  
8              
9 10     10   3621 use FindBin;
  10         8142  
  10         385  
10              
11 10     10   59 use File::Basename;
  10         15  
  10         442  
12              
13 10     10   58 use Carp qw( croak );
  10         16  
  10         348  
14 10     10   1919 use Symbol qw( qualify qualify_to_ref );
  10         3294  
  10         512  
15              
16             use File::Spec::Functions
17             qw
18 10         1254 (
19             &splitpath
20             &splitdir
21             &catpath
22             &catdir
23 10     10   2715 );
  10         4879  
24              
25             BEGIN
26             {
27             # however... there have been complaints of
28             # places where abs_path does not work.
29             #
30             # if abs_path fails on the working directory
31             # then replace it with rel2abs and live with
32             # possibly slower, redundant directories.
33             #
34             # the abs_path '//' hack allows for testing
35             # broken abs_path on primitive systems that
36             # cannot handle the rooted system being linked
37             # back to itself.
38              
39 10     10   58 use Cwd qw( &abs_path &cwd );
  10         16  
  10         1410  
40              
41 10 50   10   37 if
42             (
43             # abs_path has a fixed bug dealing with infinite
44             # recursion. if upping the version of Cwd does
45             # not fix this then the only other test I can
46             # think of is ( -e '/.' && -e '/..' && -e '/../.' )
47              
48             eval
49             {
50 10         67 abs_path '//';
51 10         40885 abs_path cwd
52             }
53             )
54             {
55             # abs_path seems clean on this platform.
56             }
57             else
58             {
59             # abs_path seems to be having problems,
60             # fix is to stub it out.
61             #
62             # undef avoids nastygram.
63              
64 0         0 my $ref = qualify_to_ref 'abs_path', __PACKAGE__;
65              
66 0         0 my $sub = File::Spec::Functions->can( 'rel2abs' );
67              
68 0         0 undef &{ $ref };
  0         0  
69              
70 0         0 *$ref = $sub
71             };
72             }
73              
74             ########################################################################
75             # package variables
76             ########################################################################
77              
78             my %defaultz =
79             (
80             base => 'lib',
81             use => undef,
82             blib => undef, # prefer ./blib at the first level
83              
84             subdir => '', # add this subdir also if found.
85             subonly => undef, # leave out lib's, use only subdir.
86             export => undef, # push variable into caller's space.
87             append => undef, # push onto existing array (vs. overwrite)
88             verbose => undef, # boolean: print inputs, results.
89             debug => undef, # boolean: set internal breakpoints.
90              
91             print => 1, # display the results
92              
93             p5lib => undef, # prefix PERL5LIB with the results
94              
95             ignore => '/,/usr', # dir's to skip looking for ./lib
96             );
97              
98             # only new directories are used, ignore pre-loads
99             # this with unwanted values.
100              
101             my %found = ();
102              
103             # saves passing this between import and $handle_args.
104              
105             my %argz = ();
106             my $verbose = '';
107             my $empty = q{};
108              
109             ########################################################################
110             # subroutines
111             ########################################################################
112              
113             # HAK ALERT: $Bin is an absolute path, there are cases
114             # where splitdir does not add the leading '' onto the
115             # directory path for it on VMS. Fix is to unshift a leading
116             # '' into @dirpath where the leading entry is true.
117              
118             my $find_libs
119             = sub
120             {
121             my $base = basename ( shift || $argz{ base } );
122              
123             my $subdir = $argz{ subdir } || '';
124              
125             my $subonly = defined $argz{ subonly };
126              
127             # for some reason, RH Enterprise V/4 has a
128             # trailing '/'; I havn't seen another copy of
129             # FindBin that does this. fix is quick enough:
130             # strip the trailing '/'.
131             #
132             # using a regex to extract the value untaints it
133             # (not useful for anything much, just helps the
134             # poor slobs stuck in taint mode).
135             #
136             # after that splitpath can grab the directory
137             # portion for future use.
138              
139             my ( $Bin ) = ( $argz{ Bin } =~ m{^ (.+) }xs );
140              
141             print STDERR "\nSearching $Bin for '$base'...\n"
142             if $verbose;
143              
144             my( $vol, $dir ) = splitpath $Bin, 1;
145              
146             my @dirpath = splitdir $dir;
147              
148             # fix for File::Spec::VMS missing the leading empty
149             # string on a split. this can be removed once File::Spec
150             # is fixed.
151              
152             unshift @dirpath, '' if $dirpath[ 0 ];
153              
154             my @libz = ();
155              
156             PATH:
157             for( 1 .. @dirpath )
158             {
159             # note that catpath is extraneous on *NIX; the
160             # volume only means something on DOS- & VMS-based
161             # filesystems, and adding an empty basename on
162             # *nix is unnecessary.
163             #
164             # HAK ALERT: the poor slobs stuck on windog have an
165             # abs_path that croaks on missing directories. have
166             # to eval the check for subdir's.
167              
168             my $abs
169             = eval
170             {
171             abs_path
172             catpath $vol, ( catdir @dirpath, $base ), $empty
173             }
174             || '';
175              
176             my $sub
177             = $subdir
178             ? eval { abs_path ( catpath '', $abs, $subdir ) } || ''
179             : ''
180             ;
181              
182             my @search = $subonly ? ( $sub ) : ( $abs, $sub );
183              
184             for my $dir ( @search )
185             {
186             if( $dir && -d $dir && ! exists $found{ $dir } )
187             {
188             $found{ $dir } = ();
189              
190             push @libz, $dir;
191              
192             last if $argz{ scalar };
193             }
194             }
195              
196             pop @dirpath
197             }
198              
199             # caller gets back the existing lib paths
200             # (including volume) walking up the path
201             # from $FindBin::Bin -> root.
202             #
203             # no libs found is empty list or undef for
204             # scalar.
205             #
206             # passing it back as a list isn't all that
207             # painful for a few paths.
208              
209             wantarray ? @libz : \@libz
210             };
211              
212             # break out the messy part into a separate block.
213              
214             my $handle_args
215             = sub
216             {
217             # discard the module, rest are arguments.
218              
219             shift;
220              
221             # anything after the module are options with arguments
222             # assigned via '='.
223              
224             %argz
225             = map
226             {
227             my $use_undef
228             = do
229             {
230             my %a = ();
231             @a{ qw( export ignore ) } = ();
232             \%a
233             };
234              
235             my ( $k, $v ) = split '=', $_, 2;
236              
237             exists $use_undef->{ $k }
238             or $v //= 1;
239              
240             # "no" inverts the sense of the test.
241              
242             $k =~ s{^no}{}
243             and $v = ! $v;
244              
245             ( $k => $v )
246             }
247             @_;
248              
249             # stuff "debug=1" into your arguments and perl -d will stop here.
250              
251             $DB::single = 1 if defined $argz{ debug };
252              
253             # default if nothing is supplied is to use the result;
254             # otherwise, without use supplied either of export or
255             # p5lib will turn off use.
256              
257             if( exists $argz{ use } )
258             {
259             # nothing further to do
260             }
261             elsif( defined $argz{ export } || defined $argz{ p5lib } )
262             {
263             $argz{ use } = undef;
264             }
265             else
266             {
267             $argz{ use } = 1;
268             }
269              
270             local $defaultz{ Bin }
271             = exists $argz{ realbin }
272             ? $FindBin::RealBin
273             : $FindBin::Bin
274             ;
275              
276             # now apply the defaults, then sanity check the result.
277             # base is a special case since it always has to exist.
278             #
279             # if $argz{ export } is defined but false then it takes
280             # its default from $argz{ base }.
281              
282             while( my($k,$v) = each %defaultz )
283             {
284             # //= doesn't work here since undef may be a
285             # legit default.
286              
287             exists $argz{ $k }
288             or
289             $argz{ $k } = $v;
290             }
291              
292             exists $argz{ base } && $argz{ base }
293             or croak "Bogus FindBin::libs: missing/false base argument, should be 'base=NAME'";
294              
295             exists $argz{ export }
296             and
297             $argz{ export } //= $argz{ base };
298              
299             $argz{ ignore } =
300             [
301             grep { $_ } split /\s*,\s*/, $argz{ ignore }
302             ];
303              
304             $verbose = defined $argz{ verbose };
305              
306             my $base = $argz{ base };
307              
308             # now locate the libraries.
309             #
310             # %found contains the abs_path results for each directory to
311             # avoid double-including directories.
312             #
313             # note: loop short-curcuts for the (usually) list.
314              
315             %found = ();
316              
317             for( @{ $argz{ ignore } } )
318             {
319             if( my $dir = eval { abs_path catdir $_, $base } )
320             {
321             if( -d $dir )
322             {
323             $found{ $dir } = 1;
324             }
325             }
326             }
327             };
328              
329             sub import
330             {
331 14     14   12683 &$handle_args;
332              
333 14         105 my @libz = $find_libs->();
334              
335             # HAK ALERT: the regex does nothing for security,
336             # just dodges -T. putting this down here instead
337             # of inside find_libs allows people to use saner
338             # untainting plans via find_libs.
339              
340 14         26 @libz = map { m{ (.+) }xs } @libz;
  14         71  
341              
342 14         36 my $caller = caller;
343              
344 14 50 33     70 if( $verbose || defined $argz{ print } )
345             {
346 14         125 local $\ = "\n";
347 14         31 local $, = "\n\t";
348              
349 14 50       51 print STDERR "Found */$argz{ base }:", @libz
350             if $verbose;
351             }
352              
353 14 50       48 if( $argz{ export } )
354             {
355             # this has to run in order to install variables that
356             # the caller is expecting to exist at runtime -- even
357             # if they are empty/undef at the end of it.
358              
359 14         108 my $ref = qualify_to_ref $argz{ export }, $caller;
360              
361 14 50       532 if( $verbose )
362             {
363 0         0 my $dest = qualify $argz{ export }, $caller;
364              
365             $argz{ scalar }
366 0 0       0 ? print STDERR "\nExporting: \$$dest\n"
367             : print STDERR "\nExporting: \@$dest\n"
368             ;
369             }
370              
371 14 50 50     82 if( $argz{ scalar } )
    50          
372             {
373 0 0       0 *$ref
374             = @libz
375             ? \$libz[0]
376             : \( my $a = '' )
377             ;
378             }
379             elsif
380             (
381             $argz{ append }
382             and
383 0         0 my $ary = *{ $ref }{ ARRAY }
384             )
385             {
386 0         0 push @$ary, @libz;
387             }
388             else
389             {
390 14         42 *$ref = \@libz
391             }
392             }
393              
394             # no 'else', these are not exclusive
395              
396 14 100       44 if( @libz )
397             {
398 12 50       39 if( defined $argz{ p5lib } )
399             {
400             # stuff the lib's found at the front of $ENV{ PERL5LIB }
401             # yes, virginia, substr is an lvalue -- and saner than
402             # dealing with \Q and a regex on arbitrary paths.
403              
404 0         0 ( substr $ENV{ PERL5LIB }, 0, 0 ) = join ':', @libz, '';
405              
406 0 0       0 print STDERR "\nUpdated PERL5LIB:\t$ENV{ PERL5LIB }\n"
407             if $verbose;
408             }
409              
410 12 100       32 if( $argz{ use } )
411             {
412             # this obviously won't work if lib ever depends
413             # on the caller's package.
414             #
415             # it does avoids issues with -T blowing up on the
416             # old eval technique.
417              
418 7         3376 require lib;
419              
420 7         4015 lib->import( @libz );
421             }
422             }
423              
424             0
425 14         5054 }
426              
427             # keep require happy
428              
429             1
430              
431             __END__