File Coverage

lib/lib/abs.pm
Criterion Covered Total %
statement 68 74 91.8
branch 18 30 60.0
condition 15 21 71.4
subroutine 13 15 86.6
pod 1 3 33.3
total 115 143 80.4


line stmt bran cond sub pod time code
1             #
2             # Copyright (c) 2007-2010 Mons Anderson . All rights reserved
3             # This program is free software; you can redistribute it and/or
4             # modify it under the same terms as Perl itself.
5             package lib::abs;
6              
7             =head1 NAME
8              
9             lib::abs - C that makes relative path absolute to caller.
10              
11             =cut
12              
13             our $VERSION = '0.93';
14              
15             =head1 SYNOPSIS
16              
17             Simple use like C:
18              
19             use lib::abs qw(./mylibs1 ../mylibs2);
20             use lib::abs 'mylibs';
21            
22             # if your path may not exists and it is ok, then:
23             use lib::abs -soft => qw(./mylibs1 ../mylibs2);
24              
25             Extended syntax (glob)
26              
27             use lib::abs 'modules/*/lib';
28              
29             There are also may be used helper function from lib::abs (see example/ex4):
30              
31             use lib::abs;
32             # ...
33             my $path = lib::abs::path('../path/relative/to/me'); # returns absolute path
34              
35             =head1 DESCRIPTION
36              
37             The main reason of this library is transformate relative paths to absolute at the C stage, and push transformed to C<@INC>.
38             Relative path basis is not the current working directory, but the location of file, where the statement is (caller file).
39             When using common C, relative paths stays relative to curernt working directory,
40              
41             # For ex:
42             # script: /opt/scripts/my.pl
43             use lib::abs '../lib';
44              
45             # We run `/opt/scripts/my.pl` having cwd /home/mons
46             # The @INC will contain '/opt/lib';
47              
48             # We run `./my.pl` having cwd /opt
49             # The @INC will contain '/opt/lib';
50              
51             # We run `../my.pl` having cwd /opt/lib
52             # The @INC will contain '/opt/lib';
53              
54             Also this module is useful when writing tests, when you want to load strictly the module from ../lib, respecting the test file.
55              
56             # t/00-test.t
57             use lib::abs '../lib';
58              
59             Also this is useful, when you running under C, use something like C, and your application may change working directory.
60             So in case of chdir C fails to reload module if the @INC contain relative paths.
61              
62             =head1 RATIONALE
63              
64             Q: We already have C and C, why we need this module?
65              
66             A: There are several reasons:
67              
68             =over 4
69              
70             =item 1) C could find path incorrectly under C
71              
72             =item 2) C works relatively to executed binary instead of relatively to caller
73              
74             =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";'>
75              
76             =item 4) C b work incorrectly, if will be called not from executed binary (see L comparison for details)
77              
78             =back
79              
80             =head1 BUGS
81              
82             None known
83              
84             =head1 COPYRIGHT & LICENSE
85              
86             Copyright 2007-2010 Mons Anderson.
87              
88             This program is free software; you can redistribute it and/or modify it
89             under the same terms as Perl itself.
90              
91             =head1 AUTHOR
92              
93             Mons Anderson, C<< >>
94              
95             =head1 CONTRIBUTORS
96              
97             Oleg Kostyuk, C<< >>
98              
99             =cut
100              
101 7     7   202888 use 5.006;
  7         24  
  7         230  
102 7     7   34 use strict;
  7         13  
  7         208  
103 7     7   35 use warnings;
  7         23  
  7         195  
104 7     7   28 use lib ();
  7         13  
  7         150  
105 7     7   34 use Cwd 3.12 qw(abs_path);
  7         146  
  7         1124  
106             $lib::abs::sep = {
107             ( map { $_ => qr{[^\\/]+$}o } qw(mswin32 netware symbian dos) ),
108             ( map { $_ => qr{[^:]+:?$}o } qw(macos) ),
109             }->{lc$^O} || qr{[^/]+$}o;
110              
111 7 50   7   2783 BEGIN { *DEBUG = sub () { 0 } unless defined &DEBUG } # use constants is heavy
112              
113 0     0   0 sub _carp { require Carp; goto &Carp::carp }
  0         0  
114 2     2   14 sub _croak { require Carp; goto &Carp::croak }
  2         294  
115 0     0   0 sub _debug ($@) { printf STDERR shift()." at @{[ (caller)[1,2] ]}\n",@_ }
  0         0  
116              
117             sub mkapath($) {
118 65     65 0 78 my $depth = shift;
119            
120             # Prepare absolute base bath
121 65         323 my ($pkg,$file) = (caller($depth))[0,1];
122 65         99 _debug "file = $file " if DEBUG > 1;
123 65         356 $file =~ s/${lib::abs::sep}//s;
124 65 50       209 $file = '.' unless length $file;
125 65         64 _debug "base path = $file" if DEBUG > 1;
126 65         1682 my $f = abs_path($file) . '/';
127 65         1820 _debug "source dir = $f " if DEBUG > 1;
128 65         245 $f;
129             }
130              
131             sub path {
132 12     12 1 7740 local $_ = shift;
133 12         22 s{^\./+}{};
134 12         37 local $!;
135 12         27 my $abs = mkapath(1) . $_;
136 12 0       598 my $ret = abs_path( $abs ) or _carp("Bad path specification: `$_' => `$abs'" . ($! ? " ($!)" : ''));
    50          
137 12         16 _debug "$_ => $ret" if DEBUG > 1;
138 12         68 $ret;
139             }
140             our $SOFT;
141             sub transform {
142 65     65 0 72 my $prefix;
143 7     7   36 no warnings 'uninitialized';
  7         8  
  7         7885  
144             map {
145 65 100 100     84 ref || m{^/} ? $_ : do {
  107         515  
146 83         103 my $lib = $_;
147 83         142 s{^\./+}{};
148 83         232 local $!;
149 83   66     241 my $abs = ( $prefix ||= mkapath(2) ) . $_;
150 83 100 100     852 if (index($abs,'*') != -1 or index($abs,'?') !=-1) {
151 12         105 _debug "transforming $abs using glob" if DEBUG > 1;
152 30         33 map {
153 12         1835 my $x;
154 30 0 33     3078 $x = abs_path( $_ ) and -d $x
    0 33        
155             or $SOFT or _croak("Bad path specification: `$lib' => `$x'" . ($! ? " ($!)" : ''));
156 30 50       133 defined $x ? ($x) : ();
157             } glob $abs;
158             } else {
159 71 50 100     6130 $_ = abs_path( $abs ) and -d $_
    100 66        
160             or $SOFT or _croak("Bad path specification: `$lib' => `$abs'" . ($! ? " ($!)" : ''));
161 69         70 _debug "$lib => $_" if DEBUG > 1;
162 69 100       837 defined $_ ? ($_) : ();
163             }
164             }
165             } @_;
166             }
167              
168             sub import {
169 54     54   46519 shift;
170 54 100       155 return unless @_;
171 53         62 my $soft = 0;
172 53 100       123 if ($_[0] eq '-soft') {
173 2         3 $soft = 1;
174 2         3 shift @_;
175             }
176 53         63 local $SOFT = $soft;
177 53         161 @_ = ( lib => transform @_ = @_ );
178 51         66 _debug "use @_\n" if DEBUG > 0;
179 51         174 goto &lib::import;
180 0         0 return;
181             }
182              
183             sub unimport {
184 12     12   8610 shift;
185 12 50       37 return unless @_;
186 12         74 @_ = ( lib => transform @_ = @_ );
187 12         24 _debug "no @_\n" if DEBUG > 0;
188 12         54 goto &lib::unimport;
189 0           return;
190             }
191              
192             1;