view release on metacpan or  search on metacpan

lib/lib/abs.pm  view on Meta::CPAN

Also this module is useful when writing tests, when you want to load strictly the module from ../lib, respecting the test file.

	# t/00-test.t
	use lib::abs '../lib';

Also this is useful, when you running under C<mod_perl>, use something like C<Apache::StatINC>, and your application may change working directory.
So in case of chdir C<StatINC> fails to reload module if the @INC contain relative paths.

=head1 RATIONALE

Q: We already have C<FindBin> and C<lib>, why we need this module?

A: There are several reasons:

=over 4

=item 1) C<FindBin> could find path incorrectly under C<mod_perl>

=item 2) C<FindBin> works relatively to executed binary instead of relatively to caller

=item 3) Perl is linguistic language, and C<`use lib::abs "..."'> semantically more clear and looks more beautiful than C<`use FindBin; use lib "$FindBin::Bin/../lib";'>

=item 4) C<FindBin> b<will> work incorrectly, if will be called not from executed binary (see L<http://github.com/Mons/lib-abs-vs-findbin> comparison for details)

=back

=head1 BUGS

None known

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2007-2020 by Mons Anderson.

This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself.

=head1 AUTHOR

Mons Anderson, C<< <mons@cpan.org> >>

=head1 CONTRIBUTORS

Oleg Kostyuk, C<< <cub@cpan.org> >>

=cut

use 5.006;
use strict;
use warnings;
use lib ();
use Cwd 3.12 qw(abs_path);
$lib::abs::sep = {
	( map { $_ => qr{[^\\/]+$}o } qw(mswin32 netware symbian dos) ),
	( map { $_ => qr{[^:]+:?$}o } qw(macos) ),
}->{lc$^O} || qr{[^/]+$}o;

BEGIN { *DEBUG = sub () { 0 } unless defined &DEBUG } # use constants is heavy

sub _carp  { require Carp; goto &Carp::carp  }
sub _croak { require Carp; goto &Carp::croak }
sub _debug ($@) { printf STDERR shift()." at @{[ (caller)[1,2] ]}\n",@_ }

sub mkapath($) {
	my $depth = shift;
	
	# Prepare absolute base bath
	my ($pkg,$file) = (caller($depth))[0,1];
	_debug "file = $file " if DEBUG > 1;
	$file =~ s/${lib::abs::sep}//s;
	$file = '.' unless length $file;
	_debug "base path = $file" if DEBUG > 1;
	my $f = abs_path($file) . '/';
	_debug "source dir = $f " if DEBUG > 1;
	$f;
}

sub path {
	local $_ = shift;
	s{^\./+}{};
	local $!;
	my $abs = mkapath(1) . $_;
	my $ret = abs_path( $abs ) or _carp("Bad path specification: `$_' => `$abs'" . ($! ? " ($!)" : ''));
	_debug "$_ => $ret" if DEBUG > 1;
	$ret;
}
our $SOFT;
sub transform {
	my $prefix;
	no warnings 'uninitialized';
	map {
		ref || m{^/} ? $_ : do {
			my $lib = $_;
			s{^\./+}{};
			local $!;
			my $abs = ( $prefix ||= mkapath(2) ) . $_;
			if (index($abs,'*') != -1 or index($abs,'?') !=-1) {
				_debug "transforming $abs using glob" if DEBUG > 1;
				map {
					my $x;
					$x = abs_path( $_ ) and -d $x
						or $SOFT or _croak("Bad path specification: `$lib' => `$x'" . ($! ? " ($!)" : ''));
					defined $x ? ($x) : ();
				} glob $abs;
			} else {
				eval {
					$_ = abs_path( $abs );
				1} and -d $_
					or $SOFT or _croak("Bad path specification: `$lib' => `$abs'" . ($! ? " ($!)" : ''));
				_debug "$lib => $_" if DEBUG > 1;
				defined $_ ? ($_) : ();
			}
		}
	} @_;
}

sub import {
	shift;
	return unless @_;
	my $soft = 0;
	if ($_[0] eq '-soft') {
		$soft = 1;