File Coverage

lib/lib/abs.pm

Criterion	Covered	Total	%
statement	70	76	92.1
branch	18	30	60.0
condition	18	24	75.0
subroutine	13	15	86.6
pod	1	3	33.3
total	120	148	81.0

#
# Copyright (c) 2007-2010 Mons Anderson . All rights reserved
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package lib::abs;

=head1 NAME

lib::abs - C that makes relative path absolute to caller.

=cut

our $VERSION = '0.94';

=head1 SYNOPSIS

Simple use like C:

	use lib::abs qw(./mylibs1 ../mylibs2);
	use lib::abs 'mylibs';

	# if your path may not exists and it is ok, then:
	use lib::abs -soft => qw(./mylibs1 ../mylibs2);

Extended syntax (glob)

	use lib::abs 'modules/*/lib';

There are also may be used helper function from lib::abs (see example/ex4):

	use lib::abs;
	# ...
	my $path = lib::abs::path('../path/relative/to/me'); # returns absolute path

=head1 DESCRIPTION

The main reason of this library is transformate relative paths to absolute at the C stage, and push transformed to C<@INC>.
Relative path basis is not the current working directory, but the location of file, where the statement is (caller file).
When using common C, relative paths stays relative to curernt working directory,

	# For ex:
	# script: /opt/scripts/my.pl
	use lib::abs '../lib';

	# We run `/opt/scripts/my.pl` having cwd /home/mons
	# The @INC will contain '/opt/lib';

	# We run `./my.pl` having cwd /opt
	# The @INC will contain '/opt/lib';

	# We run `../my.pl` having cwd /opt/lib
	# The @INC will contain '/opt/lib';

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, use something like C, and your application may change working directory.
So in case of chdir C fails to reload module if the @INC contain relative paths.

=head1 RATIONALE

Q: We already have C and C, why we need this module?

A: There are several reasons:

=over 4

=item 1) C could find path incorrectly under C

=item 2) C 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 b work incorrectly, if will be called not from executed binary (see L 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<<  >>

=head1 CONTRIBUTORS

Oleg Kostyuk, C<<  >>

=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 {
				local $@;
				eval {
					$_ = abs_path( $abs );
				};
				$_ and !$@ 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;
		shift @_;
	}
	local $SOFT = $soft;
	@_ = ( lib => transform @_ = @_ );
	_debug "use @_\n" if DEBUG > 0;
	goto &lib::import;
	return;
}

sub unimport {
	shift;
	return unless @_;
	@_ = ( lib => transform @_ = @_ );
	_debug "no @_\n" if DEBUG > 0;
	goto &lib::unimport;
	return;
}

1;