#line 1
########################################################################
# FindBin::libs
#
# use $FindBin::Bin to search for 'lib' directories and use them.
#
# default action is to look for dir's named "lib" and silently use
# the lib's without exporting anything. print turns on a short
# message with the abs_path results, export pushes out a variable
# (default name is the base value), verbose turns on decision output
# and print. export takes an optional argument with the name of a
# variable to export.
#
# Copyright (C) 2003, Steven Lembark, Workhorse Computing.
# This code is released under the same terms as Perl-5.6.1
# or any later version of Perl.
#
########################################################################
########################################################################
# housekeeping
########################################################################
package
FindBin::libs;
use
5.00601;
use
strict;
use
FindBin;
use
Symbol;
# both of these are in the standard distro and
# should be available.
use
File::Basename;
qw
(
&splitpath
&splitdir
&catpath
&catdir
);
BEGIN
{
# however... there have been complaints of
# places where abs_path does not work.
#
# if abs_path fails on the working directory
# then replace it with rel2abs and live with
# possibly slower, redundant directories.
#
# the abs_path '//' hack allows for testing
# broken abs_path on primitive systems that
# cannot handle the rooted system being linked
# back to itself.
unless
(
eval
{abs_path
'//'
; abs_path cwd } )
{
# abs_path seems to be having problems,
# fix is to stub it out. ref and sub are
# syntatic sugar, but do you really want
# to see it all on one line???
#
# undef avoids re-defining subroutine nastygram.
my
$ref
= qualify_to_ref
'abs_path'
, __PACKAGE__;
my
$sub
= File::Spec::Functions->can(
'rel2abs'
);
undef
&{
$ref
};
*$ref
=
$sub
};
}
########################################################################
# package variables
########################################################################
our
$VERSION
=
'1.40'
;
my
%defaultz
=
(
Bin
=>
$FindBin::Bin
,
base
=>
'lib'
,
use
=> 1,
subdir
=>
''
,
# add this subdir also if found.
subonly
=>
undef
,
# leave out lib's, use only subdir.
export
=>
undef
,
# push variable into caller's space.
verbose
=>
undef
,
# boolean: print inputs, results.
debug
=>
undef
,
# boolean: set internal breakpoints.
=>
undef
,
# display the results
p5lib
=>
undef
,
# prefix PERL5LIB with the results
ignore
=>
'/,/usr'
,
# dir's to skip looking for ./lib
);
# only new directories are used, ignore pre-loads
# this with unwanted values.
my
%found
= ();
# saves passing this between import and $handle_args.
my
%argz
= ();
my
$verbose
=
''
;
my
$empty
=
q{}
;
########################################################################
# subroutines
########################################################################
# HAK ALERT: $Bin is an absolute path, there are cases
# where splitdir does not add the leading '' onto the
# directory path for it on VMS. Fix is to unshift a leading
# '' into @dirpath where the leading entry is true.
sub
find_libs
{
my
$base
= basename (
shift
||
$argz
{ base } );
my
$subdir
=
$argz
{ subdir } ||
''
;
my
$subonly
=
defined
$argz
{ subonly };
# for some reason, RH Enterprise V/4 has a
# trailing '/'; I havn't seen another copy of
# FindBin that does this. fix is quick enough:
# strip the trailing '/'.
#
# using a regex to extract the value untaints it.
# after that split path can grab the directory
# portion for future use.
my
(
$Bin
) =
$argz
{ Bin } =~ m{^ (.+) }xs;
STDERR
"\nSearching $Bin for '$base'...\n"
if
$verbose
;
my
(
$vol
,
$dir
) = splitpath
$Bin
, 1;
my
@dirpath
= splitdir
$dir
;
# fix for File::Spec::VMS missing the leading empty
# string on a split. this can be removed once File::Spec
# is fixed.
unshift
@dirpath
,
''
if
$dirpath
[ 0 ];
my
@libz
= ();
for
( 1 ..
@dirpath
)
{
# note that catpath is extraneous on *NIX; the
# volume only means something on DOS- & VMS-based
# filesystems, and adding an empty basename on
# *nix is unnecessary.
#
# HAK ALERT: the poor slobs stuck on windog have an
# abs_path that croaks on missing directories. have
# to eval the check for subdir's.
my
$abs
=
eval
{ abs_path catpath
$vol
, ( catdir
@dirpath
,
$base
),
$empty
}
||
''
;
my
$sub
=
$subdir
?
eval
{ abs_path ( catpath
''
,
$abs
,
$subdir
) } ||
''
:
''
;
my
@search
=
$subonly
? (
$sub
) : (
$abs
,
$sub
);
for
my
$dir
(
@search
)
{
if
(
$dir
&& -d
$dir
&& !
exists
$found
{
$dir
} )
{
$found
{
$dir
} = 1;
push
@libz
,
$dir
;
}
}
pop
@dirpath
}
# caller gets back the existing lib paths
# (including volume) walking up the path
# from $FindBin::Bin -> root.
#
# passing it back as a list isn't all that
# painful for a few paths.
wantarray
?
@libz
: \
@libz
};
# break out the messy part into a separate block.
my
$handle_args
=
sub
{
# discard the module, rest are arguments.
shift
;
# anything after the module are options with arguments
# assigned via '='.
%argz
=
map
{
my
(
$k
,
$v
) =
split
'='
,
$_
, 2;
if
(
$k
=~ s{^(?:!|
no
)}{} )
{
$k
=>
undef
}
else
{
$k
=> (
$v
||
''
)
}
}
@_
;
# stuff "debug=1" into your arguments and perl -d will stop here.
$DB::single
= 1
if
$argz
{debug};
# use lib behavior is turned off by default if export or
# perl5lib udpate are requested.
exists
$argz
{
use
} or
$defaultz
{
use
} = !
exists
$argz
{export};
exists
$argz
{
use
} or
$defaultz
{
use
} = !
exists
$argz
{p5lib};
# now apply the defaults, then sanity check the result.
# base is a special case since it always has to exist.
#
# if $argz{export} is defined but false then it takes
# its default from $argz{base}.
exists
$argz
{
$_
} or
$argz
{
$_
} =
$defaultz
{
$_
}
for
keys
%defaultz
;
exists
$argz
{base} &&
$argz
{base}
or croak
"Bogus FindBin::libs: missing/false base argument, should be 'base=NAME'"
;
defined
$argz
{export} and
$argz
{export} ||=
$argz
{base};
$argz
{ ignore } =
[
grep
{
$_
}
split
/\s*,\s*/,
$argz
{ignore}
];
$verbose
=
defined
$argz
{verbose};
my
$base
=
$argz
{base};
# now locate the libraries.
#
# %found contains the abs_path results for each directory to
# avoid double-including directories.
#
# note: loop short-curcuts for the (usually) list.
%found
= ();
for
( @{
$argz
{ ignore } } )
{
if
(
my
$dir
=
eval
{ abs_path catdir
$_
,
$base
} )
{
if
( -d
$dir
)
{
$found
{
$dir
} = 1;
}
}
}
};
sub
import
{
&$handle_args
;
my
@libz
= find_libs;
# HAK ALERT: the regex does nothing for security,
# just dodges -T. putting this down here instead
# of inside find_libs allows people to use saner
# untainting plans via find_libs.
@libz
=
map
{ m{ (.+) }x }
@libz
;
my
$caller
=
caller
;
if
(
$verbose
||
defined
$argz
{
} )
{
local
$\ =
"\n"
;
local
$, =
"\n\t"
;
STDERR
"Found */$argz{ base }:"
,
@libz
}
if
(
$argz
{export} )
{
my
$caller
=
caller
;
STDERR
join
''
,
"\nExporting: @"
,
$caller
,
'::'
,
$argz
{export},
"\n"
if
$verbose
;
# Symbol this is cleaner than "no strict"
# for installing the array.
my
$ref
= qualify_to_ref
$argz
{ export },
$caller
;
*$ref
= \
@libz
;
}
if
(
defined
$argz
{ p5lib } )
{
# stuff the lib's found at the front of $ENV{ PERL5LIB }
(
substr
$ENV
{ PERL5LIB }, 0, 0 ) =
join
':'
,
@libz
,
''
if
@libz
;
STDERR
"\nUpdated PERL5LIB:\t$ENV{ PERL5LIB }\n"
if
$verbose
;
}
if
(
$argz
{
use
} &&
@libz
)
{
# this obviously won't work if lib ever depends
# on the caller's package.
#
# it does avoids issues with -T blowing up on the
# old eval technique.
lib->
import
(
@libz
);
}
0
}
# keep require happy
1
__END__