Commit | Line | Data |
6aaee015 |
1 | package CPANPLUS::inc; |
2 | |
3 | =head1 NAME |
4 | |
5 | CPANPLUS::inc |
6 | |
7 | =head1 DESCRIPTION |
8 | |
9 | OBSOLETE |
10 | |
11 | =cut |
12 | |
13 | sub original_perl5opt { $ENV{PERL5OPT} }; |
14 | sub original_perl5lib { $ENV{PERL5LIB} }; |
15 | sub original_inc { @INC }; |
16 | |
17 | 1; |
18 | |
19 | __END__ |
20 | |
21 | use strict; |
22 | use vars qw[$DEBUG $VERSION $ENABLE_INC_HOOK %LIMIT $QUIET]; |
23 | use File::Spec (); |
24 | use Config (); |
25 | |
26 | ### 5.6.1. nags about require + bareword otherwise ### |
27 | use lib (); |
28 | |
29 | $QUIET = 0; |
30 | $DEBUG = 0; |
31 | %LIMIT = (); |
32 | |
33 | =pod |
34 | |
35 | =head1 NAME |
36 | |
37 | CPANPLUS::inc - runtime inclusion of privately bundled modules |
38 | |
39 | =head1 SYNOPSIS |
40 | |
41 | ### set up CPANPLUS::inc to do it's thing ### |
42 | BEGIN { use CPANPLUS::inc }; |
43 | |
44 | ### enable debugging ### |
45 | use CPANPLUS::inc qw[DEBUG]; |
46 | |
47 | =head1 DESCRIPTION |
48 | |
49 | This module enables the use of the bundled modules in the |
50 | C<CPANPLUS/inc> directory of this package. These modules are bundled |
51 | to make sure C<CPANPLUS> is able to bootstrap itself. It will do the |
52 | following things: |
53 | |
54 | =over 4 |
55 | |
56 | =item Put a coderef at the beginning of C<@INC> |
57 | |
58 | This allows us to decide which module to load, and where to find it. |
59 | For details on what we do, see the C<INTERESTING MODULES> section below. |
60 | Also see the C<CAVEATS> section. |
61 | |
62 | =item Add the full path to the C<CPANPLUS/inc> directory to C<$ENV{PERL5LIB>. |
63 | |
64 | This allows us to find our bundled modules even if we spawn off a new |
65 | process. Although it's not able to do the selective loading as the |
66 | coderef in C<@INC> could, it's a good fallback. |
67 | |
68 | =back |
69 | |
70 | =head1 METHODS |
71 | |
72 | =head2 CPANPLUS::inc->inc_path() |
73 | |
74 | Returns the full path to the C<CPANPLUS/inc> directory. |
75 | |
76 | =head2 CPANPLUS::inc->my_path() |
77 | |
78 | Returns the full path to be added to C<@INC> to load |
79 | C<CPANPLUS::inc> from. |
80 | |
81 | =head2 CPANPLUS::inc->installer_path() |
82 | |
83 | Returns the full path to the C<CPANPLUS/inc/installers> directory. |
84 | |
85 | =cut |
86 | |
87 | { my $ext = '.pm'; |
88 | my $file = (join '/', split '::', __PACKAGE__) . $ext; |
89 | |
90 | ### os specific file path, if you're not on unix |
91 | my $osfile = File::Spec->catfile( split('::', __PACKAGE__) ) . $ext; |
92 | |
93 | ### this returns a unixy path, compensate if you're on non-unix |
94 | my $path = File::Spec->rel2abs( |
95 | File::Spec->catfile( split '/', $INC{$file} ) |
96 | ); |
97 | |
98 | ### don't forget to quotemeta; win32 paths are special |
99 | my $qm_osfile = quotemeta $osfile; |
100 | my $path_to_me = $path; $path_to_me =~ s/$qm_osfile$//i; |
101 | my $path_to_inc = $path; $path_to_inc =~ s/$ext$//i; |
102 | my $path_to_installers = File::Spec->catdir( $path_to_inc, 'installers' ); |
103 | |
104 | sub inc_path { return $path_to_inc } |
105 | sub my_path { return $path_to_me } |
106 | sub installer_path { return $path_to_installers } |
107 | } |
108 | |
109 | =head2 CPANPLUS::inc->original_perl5lib |
110 | |
111 | Returns the value of $ENV{PERL5LIB} the way it was when C<CPANPLUS::inc> |
112 | got loaded. |
113 | |
114 | =head2 CPANPLUS::inc->original_perl5opt |
115 | |
116 | Returns the value of $ENV{PERL5OPT} the way it was when C<CPANPLUS::inc> |
117 | got loaded. |
118 | |
119 | =head2 CPANPLUS::inc->original_inc |
120 | |
121 | Returns the value of @INC the way it was when C<CPANPLUS::inc> got |
122 | loaded. |
123 | |
124 | =head2 CPANPLUS::inc->limited_perl5opt(@modules); |
125 | |
126 | Returns a string you can assign to C<$ENV{PERL5OPT}> to have a limited |
127 | include facility from C<CPANPLUS::inc>. It will roughly look like: |
128 | |
129 | -I/path/to/cpanplus/inc -MCPANPLUS::inc=module1,module2 |
130 | |
131 | =cut |
132 | |
133 | { my $org_opt = $ENV{PERL5OPT}; |
134 | my $org_lib = $ENV{PERL5LIB}; |
135 | my @org_inc = @INC; |
136 | |
137 | sub original_perl5opt { $org_opt || ''}; |
138 | sub original_perl5lib { $org_lib || ''}; |
139 | sub original_inc { @org_inc, __PACKAGE__->my_path }; |
140 | |
141 | sub limited_perl5opt { |
142 | my $pkg = shift; |
143 | my $lim = join ',', @_ or return; |
144 | |
145 | ### -Icp::inc -Mcp::inc=mod1,mod2,mod3 |
146 | my $opt = '-I' . __PACKAGE__->my_path . ' ' . |
147 | '-M' . __PACKAGE__ . "=$lim"; |
148 | |
149 | $opt .= $Config::Config{'path_sep'} . |
150 | CPANPLUS::inc->original_perl5opt |
151 | if CPANPLUS::inc->original_perl5opt; |
152 | |
153 | return $opt; |
154 | } |
155 | } |
156 | |
157 | =head2 CPANPLUS::inc->interesting_modules() |
158 | |
159 | Returns a hashref with modules we're interested in, and the minimum |
160 | version we need to find. |
161 | |
162 | It would looks something like this: |
163 | |
164 | { File::Fetch => 0.06, |
165 | IPC::Cmd => 0.22, |
166 | .... |
167 | } |
168 | |
169 | =cut |
170 | |
171 | { |
172 | my $map = { |
173 | ### used to have 0.80, but not it was never released by coral |
174 | ### 0.79 *should* be good enough for now... asked coral to |
175 | ### release 0.80 on 10/3/2006 |
176 | 'IPC::Run' => '0.79', |
177 | 'File::Fetch' => '0.07', |
178 | #'File::Spec' => '0.82', # can't, need it ourselves... |
179 | 'IPC::Cmd' => '0.24', |
180 | 'Locale::Maketext::Simple' => 0, |
181 | 'Log::Message' => 0, |
182 | 'Module::Load' => '0.10', |
183 | 'Module::Load::Conditional' => '0.07', |
184 | 'Params::Check' => '0.22', |
185 | 'Term::UI' => '0.05', |
186 | 'Archive::Extract' => '0.07', |
187 | 'Archive::Tar' => '1.23', |
188 | 'IO::Zlib' => '1.04', |
189 | 'Object::Accessor' => '0.03', |
190 | 'Module::CoreList' => '1.97', |
191 | 'Module::Pluggable' => '2.4', |
192 | 'Module::Loaded' => 0, |
193 | #'Config::Auto' => 0, # not yet, not using it yet |
194 | }; |
195 | |
196 | sub interesting_modules { return $map; } |
197 | } |
198 | |
199 | |
200 | =head1 INTERESTING MODULES |
201 | |
202 | C<CPANPLUS::inc> doesn't even bother to try find and find a module |
203 | it's not interested in. A list of I<interesting modules> can be |
204 | obtained using the C<interesting_modules> method described above. |
205 | |
206 | Note that all subclassed modules of an C<interesting module> will |
207 | also be attempted to be loaded, but a version will not be checked. |
208 | |
209 | When it however does encounter a module it is interested in, it will |
210 | do the following things: |
211 | |
212 | =over 4 |
213 | |
214 | =item Loop over your @INC |
215 | |
216 | And for every directory it finds there (skipping all non directories |
217 | -- see the C<CAVEATS> section), see if the module requested can be |
218 | found there. |
219 | |
220 | =item Check the version on every suitable module found in @INC |
221 | |
222 | After a list of modules has been gathered, the version of each of them |
223 | is checked to find the one with the highest version, and return that as |
224 | the module to C<use>. |
225 | |
226 | This enables us to use a recent enough version from our own bundled |
227 | modules, but also to use a I<newer> module found in your path instead, |
228 | if it is present. Thus having access to bugfixed versions as they are |
229 | released. |
230 | |
231 | If for some reason no satisfactory version could be found, a warning |
232 | will be emitted. See the C<DEBUG> section for more details on how to |
233 | find out exactly what C<CPANPLUS::inc> is doing. |
234 | |
235 | =back |
236 | |
237 | =cut |
238 | |
239 | { my $Loaded; |
240 | my %Cache; |
241 | |
242 | |
243 | ### returns the path to a certain module we found |
244 | sub path_to { |
245 | my $self = shift; |
246 | my $mod = shift or return; |
247 | |
248 | ### find the directory |
249 | my $path = $Cache{$mod}->[0][2] or return; |
250 | |
251 | ### probe them explicitly for a special file, because the |
252 | ### dir we found the file in vs our own paths may point to the |
253 | ### same location, but might not pass an 'eq' test. |
254 | |
255 | ### it's our inc-path |
256 | return __PACKAGE__->inc_path |
257 | if -e File::Spec->catfile( $path, '.inc' ); |
258 | |
259 | ### it's our installer path |
260 | return __PACKAGE__->installer_path |
261 | if -e File::Spec->catfile( $path, '.installers' ); |
262 | |
263 | ### it's just some dir... |
264 | return $path; |
265 | } |
266 | |
267 | ### just a debug method |
268 | sub _show_cache { return \%Cache }; |
269 | |
270 | sub import { |
271 | my $pkg = shift; |
272 | |
273 | ### filter DEBUG, and toggle the global |
274 | map { $LIMIT{$_} = 1 } |
275 | grep { /DEBUG/ ? ++$DEBUG && 0 : |
276 | /QUIET/ ? ++$QUIET && 0 : |
277 | 1 |
278 | } @_; |
279 | |
280 | ### only load once ### |
281 | return 1 if $Loaded++; |
282 | |
283 | ### first, add our own private dir to the end of @INC: |
284 | { |
285 | push @INC, __PACKAGE__->my_path, __PACKAGE__->inc_path, |
286 | __PACKAGE__->installer_path; |
287 | |
288 | ### XXX stop doing this, there's no need for it anymore; |
289 | ### none of the shell outs need to have this set anymore |
290 | # ### add the path to this module to PERL5OPT in case |
291 | # ### we spawn off some programs... |
292 | # ### then add this module to be loaded in PERL5OPT... |
293 | # { local $^W; |
294 | # $ENV{'PERL5LIB'} .= $Config::Config{'path_sep'} |
295 | # . __PACKAGE__->my_path |
296 | # . $Config::Config{'path_sep'} |
297 | # . __PACKAGE__->inc_path; |
298 | # |
299 | # $ENV{'PERL5OPT'} = '-M'. __PACKAGE__ . ' ' |
300 | # . ($ENV{'PERL5OPT'} || ''); |
301 | # } |
302 | } |
303 | |
304 | ### next, find the highest version of a module that |
305 | ### we care about. very basic check, but will |
306 | ### have to do for now. |
307 | lib->import( sub { |
308 | my $path = pop(); # path to the pm |
309 | my $module = $path or return; # copy of the path, to munge |
310 | my @parts = split qr!\\|/!, $path; # dirs + file name; could be |
311 | # win32 paths =/ |
312 | my $file = pop @parts; # just the file name |
313 | my $map = __PACKAGE__->interesting_modules; |
314 | |
315 | ### translate file name to module name |
316 | ### could contain win32 paths delimiters |
317 | $module =~ s!/|\\!::!g; $module =~ s/\.pm//i; |
318 | |
319 | my $check_version; my $try; |
320 | ### does it look like a module we care about? |
321 | my ($interesting) = grep { $module =~ /^$_/ } keys %$map; |
322 | ++$try if $interesting; |
323 | |
324 | ### do we need to check the version too? |
325 | ++$check_version if exists $map->{$module}; |
326 | |
327 | ### we don't care ### |
328 | unless( $try ) { |
329 | warn __PACKAGE__ .": Not interested in '$module'\n" if $DEBUG; |
330 | return; |
331 | |
332 | ### we're not allowed |
333 | } elsif ( $try and keys %LIMIT ) { |
334 | unless( grep { $module =~ /^$_/ } keys %LIMIT ) { |
335 | warn __PACKAGE__ .": Limits active, '$module' not allowed ". |
336 | "to be loaded" if $DEBUG; |
337 | return; |
338 | } |
339 | } |
340 | |
341 | ### found filehandles + versions ### |
342 | my @found; |
343 | DIR: for my $dir (@INC) { |
344 | next DIR unless -d $dir; |
345 | |
346 | ### get the full path to the module ### |
347 | my $pm = File::Spec->catfile( $dir, @parts, $file ); |
348 | |
349 | ### open the file if it exists ### |
350 | if( -e $pm ) { |
351 | my $fh; |
352 | unless( open $fh, "$pm" ) { |
353 | warn __PACKAGE__ .": Could not open '$pm': $!\n" |
354 | if $DEBUG; |
355 | next DIR; |
356 | } |
357 | |
358 | my $found; |
359 | ### XXX stolen from module::load::conditional ### |
360 | while (local $_ = <$fh> ) { |
361 | |
362 | ### the following regexp comes from the |
363 | ### ExtUtils::MakeMaker documentation. |
364 | if ( /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ ) { |
365 | |
366 | ### this will eval the version in to $VERSION if it |
367 | ### was declared as $VERSION in the module. |
368 | ### else the result will be in $res. |
369 | ### this is a fix on skud's Module::InstalledVersion |
370 | |
371 | local $VERSION; |
372 | my $res = eval $_; |
373 | |
374 | ### default to '0.0' if there REALLY is no version |
375 | ### all to satisfy warnings |
376 | $found = $VERSION || $res || '0.0'; |
377 | |
378 | ### found what we came for |
379 | last if $found; |
380 | } |
381 | } |
382 | |
383 | ### no version defined at all? ### |
384 | $found ||= '0.0'; |
385 | |
386 | warn __PACKAGE__ .": Found match for '$module' in '$dir' " |
387 | ."with version '$found'\n" if $DEBUG; |
388 | |
389 | ### reset the position of the filehandle ### |
390 | seek $fh, 0, 0; |
391 | |
392 | ### store the found version + filehandle it came from ### |
393 | push @found, [ $found, $fh, $dir, $pm ]; |
394 | } |
395 | |
396 | } # done looping over all the dirs |
397 | |
398 | ### nothing found? ### |
399 | unless (@found) { |
400 | warn __PACKAGE__ .": Unable to find any module named " |
401 | . "'$module'\n" if $DEBUG; |
402 | return; |
403 | } |
404 | |
405 | ### find highest version |
406 | ### or the one in the same dir as a base module already loaded |
407 | ### or otherwise, the one not bundled |
408 | ### or otherwise the newest |
409 | my @sorted = sort { |
410 | _vcmp($b->[0], $a->[0]) || |
411 | ($Cache{$interesting} |
412 | ?($b->[2] eq $Cache{$interesting}->[0][2]) <=> |
413 | ($a->[2] eq $Cache{$interesting}->[0][2]) |
414 | : 0 ) || |
415 | (($a->[2] eq __PACKAGE__->inc_path) <=> |
416 | ($b->[2] eq __PACKAGE__->inc_path)) || |
417 | (-M $a->[3] <=> -M $b->[3]) |
418 | } @found; |
419 | |
420 | warn __PACKAGE__ .": Best match for '$module' is found in " |
421 | ."'$sorted[0][2]' with version '$sorted[0][0]'\n" |
422 | if $DEBUG; |
423 | |
424 | if( $check_version and |
425 | not (_vcmp($sorted[0][0], $map->{$module}) >= 0) |
426 | ) { |
427 | warn __PACKAGE__ .": Cannot find high enough version for " |
428 | ."'$module' -- need '$map->{$module}' but " |
429 | ."only found '$sorted[0][0]'. Returning " |
430 | ."highest found version but this may cause " |
431 | ."problems\n" unless $QUIET; |
432 | }; |
433 | |
434 | ### right, so that damn )#$(*@#)(*@#@ Module::Build makes |
435 | ### assumptions about the environment (especially its own tests) |
436 | ### and blows up badly if it's loaded via CP::inc :( |
437 | ### so, if we find a newer version on disk (which would happen when |
438 | ### upgrading or having upgraded, just pretend we didn't find it, |
439 | ### let it be loaded via the 'normal' way. |
440 | ### can't even load the *proper* one via our CP::inc, as it will |
441 | ### get upset just over the fact it's loaded via a non-standard way |
442 | if( $module =~ /^Module::Build/ and |
443 | $sorted[0][2] ne __PACKAGE__->inc_path and |
444 | $sorted[0][2] ne __PACKAGE__->installer_path |
445 | ) { |
446 | warn __PACKAGE__ .": Found newer version of 'Module::Build::*' " |
447 | ."elsewhere in your path. Pretending to not " |
448 | ."have found it\n" if $DEBUG; |
449 | return; |
450 | } |
451 | |
452 | ### store what we found for this module |
453 | $Cache{$module} = \@sorted; |
454 | |
455 | ### best matching filehandle ### |
456 | return $sorted[0][1]; |
457 | } ); |
458 | } |
459 | } |
460 | |
461 | ### XXX copied from C::I::Utils, so there's no circular require here! |
462 | sub _vcmp { |
463 | my ($x, $y) = @_; |
464 | s/_//g foreach $x, $y; |
465 | return $x <=> $y; |
466 | } |
467 | |
468 | =pod |
469 | |
470 | =head1 DEBUG |
471 | |
472 | Since this module does C<Clever Things> to your search path, it might |
473 | be nice sometimes to figure out what it's doing, if things don't work |
474 | as expected. You can enable a debug trace by calling the module like |
475 | this: |
476 | |
477 | use CPANPLUS::inc 'DEBUG'; |
478 | |
479 | This will show you what C<CPANPLUS::inc> is doing, which might look |
480 | something like this: |
481 | |
482 | CPANPLUS::inc: Found match for 'Params::Check' in |
483 | '/opt/lib/perl5/site_perl/5.8.3' with version '0.07' |
484 | CPANPLUS::inc: Found match for 'Params::Check' in |
485 | '/my/private/lib/CPANPLUS/inc' with version '0.21' |
486 | CPANPLUS::inc: Best match for 'Params::Check' is found in |
487 | '/my/private/lib/CPANPLUS/inc' with version '0.21' |
488 | |
489 | =head1 CAVEATS |
490 | |
491 | This module has 2 major caveats, that could lead to unexpected |
492 | behaviour. But currently I don't know how to fix them, Suggestions |
493 | are much welcomed. |
494 | |
495 | =over 4 |
496 | |
497 | =item On multiple C<use lib> calls, our coderef may not be the first in @INC |
498 | |
499 | If this happens, although unlikely in most situations and not happening |
500 | when calling the shell directly, this could mean that a lower (too low) |
501 | versioned module is loaded, which might cause failures in the |
502 | application. |
503 | |
504 | =item Non-directories in @INC |
505 | |
506 | Non-directories are right now skipped by CPANPLUS::inc. They could of |
507 | course lead us to newer versions of a module, but it's too tricky to |
508 | verify if they would. Therefor they are skipped. In the worst case |
509 | scenario we'll find the sufficing version bundled with CPANPLUS. |
510 | |
511 | |
512 | =cut |
513 | |
514 | 1; |
515 | |
516 | # Local variables: |
517 | # c-indentation-style: bsd |
518 | # c-basic-offset: 4 |
519 | # indent-tabs-mode: nil |
520 | # End: |
521 | # vim: expandtab shiftwidth=4: |
522 | |