File Coverage

blib/lib/File/AddInc.pm
Criterion Covered Total %
statement 43 116 37.0
branch 3 28 10.7
condition 0 6 0.0
subroutine 13 25 52.0
pod 2 11 18.1
total 61 186 32.8


line stmt bran cond sub pod time code
1             package File::AddInc;
2 2     2   5277 use 5.008001;
  2         14  
3 2     2   10 use strict;
  2         5  
  2         38  
4 2     2   9 use warnings;
  2         3  
  2         53  
5 2     2   487 use mro qw/c3/;
  2         734  
  2         8  
6              
7             our $VERSION = "0.002";
8              
9 2     2   104 use File::Spec;
  2         3  
  2         51  
10 2     2   11 use File::Basename;
  2         4  
  2         110  
11 2     2   12 use Cwd ();
  2         5  
  2         53  
12 2     2   516 use lib ();
  2         692  
  2         34  
13 2     2   10 use Carp ();
  2         4  
  2         52  
14              
15 2     2   10 use constant DEBUG => $ENV{DEBUG_MOP4IMPORT};
  2         3  
  2         306  
16              
17             {
18             package
19             File::AddInc::Opts;
20 2     2   1051 use fields qw/caller callpack filename line/;
  2         3211  
  2         6  
21              
22             # This Opts->new does not bless the hash.
23             sub new {
24 0     0   0 my ($pack, %opts) = @_;
25 0         0 my __PACKAGE__ $opts = \%opts;
26             ($opts->{callpack}, $opts->{filename}, $opts->{line})
27 0         0 = @{$opts->{caller}};
  0         0  
28 0         0 $opts;
29             }
30             }
31             sub Opts () {'File::AddInc::Opts'}
32              
33             #
34             # Limited version of MOP4Import::Declare#import()
35             #
36             sub import {
37 0     0   0 my ($pack, @pragma) = @_;
38              
39 0         0 my Opts $opts = $pack->Opts->new(caller => [caller]);
40              
41 0 0       0 @pragma = (-file_inc) unless @pragma;
42              
43 0         0 $pack->dispatch_declare($opts, @pragma);
44             }
45              
46             sub dispatch_declare {
47 0     0 0 0 (my $pack, my Opts $opts, my @pragma) = @_;
48              
49 0         0 foreach my $pragmaSpec (@pragma) {
50              
51 0         0 my ($pragma, @args) = do {
52 0 0 0     0 if (ref $pragmaSpec eq 'ARRAY') {
    0 0        
    0          
53 0         0 @$pragmaSpec
54             }
55             elsif (not ref $pragmaSpec and $pragmaSpec =~ /^-(\w+)$/) {
56 0         0 $1
57             }
58             elsif (not ref $pragmaSpec and $pragmaSpec =~ /^\$\w+\z/) {
59 0         0 (libdir_var => $pragmaSpec)
60             }
61             else {
62 0         0 Carp::croak "Unsupported pragma: $pragmaSpec";
63             }
64             };
65              
66 0 0       0 my $sub = $pack->can("declare_$pragma")
67             or Carp::croak "Unknown pragma: $pragma";
68              
69 0         0 $sub->($pack, $opts, @args);
70             }
71             }
72              
73             sub declare_file_inc {
74 0     0 0 0 (my $pack, my Opts $opts) = @_;
75              
76 0         0 my $libdir = libdir($pack, $opts->{callpack}, $opts->{filename});
77              
78 0         0 $pack->add_inc_if_necessary($libdir);
79             }
80              
81             sub declare_local_lib {
82 0     0 0 0 (my $pack, my Opts $opts) = @_;
83              
84 0         0 $pack->declare_these_libdirs($opts, '', [dirname => "local/lib/perl5"]);
85             }
86              
87             sub add_inc_if_necessary {
88 0     0 1 0 my ($pack, @libdir) = @_;
89              
90 0 0       0 if (my @necessary = grep {
91              
92 0         0 my $dir = $_;
93 0 0       0 -d $dir and not grep {$dir eq $_} @INC;
  0         0  
94              
95             } @libdir) {
96              
97 0         0 print STDERR "# use lib ", join(", ", map(qq{'$_'}, @necessary))
98             , "\n" if DEBUG;
99              
100 0         0 lib->import(@necessary);
101              
102             } else {
103              
104 0         0 print STDERR "# No need to add libs: ", join(", ", map(qq{'$_'}, @libdir))
105             , "\n" if DEBUG;
106             }
107             }
108              
109             sub declare_libdir_var {
110 0     0 0 0 (my $pack, my Opts $opts, my $varname) = @_;
111              
112 0         0 my $libdir = libdir($pack, $opts->{callpack}, $opts->{filename});
113              
114 0         0 $varname =~ s/^\$//;
115              
116 0         0 my $fullvarname = join("::", $opts->{callpack}, $varname);
117              
118 2     2   1535 my $glob = do {no strict qw/refs/; \*{$fullvarname}};
  2         5  
  2         1513  
  0         0  
  0         0  
  0         0  
119              
120 0         0 print STDERR "# set \$$fullvarname = '$libdir'\n" if DEBUG;
121              
122 0         0 *$glob = \$libdir;
123             }
124              
125             sub declare_these_libdirs {
126 0     0 0 0 (my $pack, my Opts $opts, my @dirSpec) = @_;
127              
128 0         0 my $libdir = libdir($pack, $opts->{callpack}, $opts->{filename});
129              
130             my @libdir = map {
131 0 0       0 if (ref $_) {
  0         0  
132              
133 0         0 my ($kind, @rest) = @$_;
134              
135 0 0       0 my $sub = $pack->can("libdir_to_$kind")
136             or Carp::croak "Unknown libdir spec: $kind";
137              
138 0         0 my $realPrefix = $sub->($pack, $libdir);
139              
140 0         0 File::Spec->catfile($realPrefix, map {split(m{/}, $_)} @rest);
  0         0  
141              
142             }
143             # elsif (/\%s/) {
144             # File::Spec->catfile(split m{/}, sprintf($_, $libdir));
145             # }
146             else {
147              
148 0         0 File::Spec->catfile($libdir, split(m{/}, $_));
149             }
150             } @dirSpec;
151              
152 0         0 add_inc_if_necessary($pack, @libdir);
153             }
154              
155             sub libdir_to_libdir {
156 0     0 0 0 my ($pack, $libdir) = @_;
157 0         0 $libdir;
158             }
159              
160             sub libdir_to_dirname {
161 0     0 0 0 my ($pack, $libdir) = @_;
162 0         0 dirname($libdir);
163             }
164              
165             sub libdir {
166 2     2 1 4754 my ($pack, @caller) = @_;
167              
168 2 50       8 my ($callpack, $filename) = @caller ? @caller : caller;
169              
170 2         11 (my $packfn = $callpack) =~ s,::,/,g;
171 2         4 $packfn .= ".pm";
172              
173 2 50       73 my $realFn = -l $filename
174             ? resolve_symlink($pack, $filename)
175             : $filename;
176              
177 2         62 my $absfn = File::Spec->rel2abs($realFn);
178              
179 2 50       27 $absfn =~ /\Q$packfn\E\z/
180             or Carp::croak("Can't handle this case! absfn=$absfn; packfn=$packfn");
181              
182 2         16 substr($absfn, 0, length($absfn) - length($packfn) - 1);
183             }
184              
185             sub resolve_symlink {
186 0     0 0   my ($pack, $filePath) = @_;
187              
188 0           print STDERR "# resolve_symlink($filePath)...\n" if DEBUG;
189              
190 0           (undef, my ($realDir)) = fileparse($filePath);
191              
192 0           while (defined (my $linkText = readlink $filePath)) {
193 0           ($filePath, $realDir) = resolve_symlink_1($pack, $linkText, $realDir);
194 0           print STDERR "# => $filePath (realDir=$realDir)\n" if DEBUG;
195             }
196              
197 0           return $filePath;
198             }
199              
200             sub resolve_symlink_1 {
201 0     0 0   my ($pack, $linkText, $realDir) = @_;
202              
203 0           my $filePath = do {
204 0 0         if (File::Spec->file_name_is_absolute($linkText)) {
205 0           $linkText;
206             } else {
207 0           File::Spec->catfile($realDir, $linkText);
208             }
209             };
210              
211 0 0         if (wantarray) {
212             # purify x/../y to y
213 0           my $realPath = Cwd::realpath($filePath);
214 0           (undef, $realDir) = fileparse($realPath);
215 0           ($realPath, $realDir);
216             } else {
217 0           $filePath;
218             }
219             }
220              
221             1;