1package Module::Load::Conditional;
2
3use strict;
4
5use Module::Load qw/load autoload_remote/;
6use Params::Check                       qw[check];
7use Locale::Maketext::Simple Style  => 'gettext';
8
9use Carp        ();
10use File::Spec  ();
11use FileHandle  ();
12use version;
13
14use Module::Metadata ();
15
16use constant ON_VMS   => $^O eq 'VMS';
17use constant ON_WIN32 => $^O eq 'MSWin32' ? 1 : 0;
18use constant QUOTE    => do { ON_WIN32 ? q["] : q['] };
19
20BEGIN {
21    use vars        qw[ $VERSION @ISA $VERBOSE $CACHE @EXPORT_OK $DEPRECATED
22                        $FIND_VERSION $ERROR $CHECK_INC_HASH $FORCE_SAFE_INC ];
23    use Exporter;
24    @ISA            = qw[Exporter];
25    $VERSION        = '0.68';
26    $VERBOSE        = 0;
27    $DEPRECATED     = 0;
28    $FIND_VERSION   = 1;
29    $CHECK_INC_HASH = 0;
30    $FORCE_SAFE_INC = 0;
31    @EXPORT_OK      = qw[check_install can_load requires];
32}
33
34=pod
35
36=head1 NAME
37
38Module::Load::Conditional - Looking up module information / loading at runtime
39
40=head1 SYNOPSIS
41
42    use Module::Load::Conditional qw[can_load check_install requires];
43
44
45    my $use_list = {
46            CPANPLUS        => 0.05,
47            LWP             => 5.60,
48            'Test::More'    => undef,
49    };
50
51    print can_load( modules => $use_list )
52            ? 'all modules loaded successfully'
53            : 'failed to load required modules';
54
55
56    my $rv = check_install( module => 'LWP', version => 5.60 )
57                or print 'LWP is not installed!';
58
59    print 'LWP up to date' if $rv->{uptodate};
60    print "LWP version is $rv->{version}\n";
61    print "LWP is installed as file $rv->{file}\n";
62
63
64    print "LWP requires the following modules to be installed:\n";
65    print join "\n", requires('LWP');
66
67    ### allow M::L::C to peek in your %INC rather than just
68    ### scanning @INC
69    $Module::Load::Conditional::CHECK_INC_HASH = 1;
70
71    ### reset the 'can_load' cache
72    undef $Module::Load::Conditional::CACHE;
73
74    ### don't have Module::Load::Conditional issue warnings --
75    ### default is '1'
76    $Module::Load::Conditional::VERBOSE = 0;
77
78    ### The last error that happened during a call to 'can_load'
79    my $err = $Module::Load::Conditional::ERROR;
80
81
82=head1 DESCRIPTION
83
84Module::Load::Conditional provides simple ways to query and possibly load any of
85the modules you have installed on your system during runtime.
86
87It is able to load multiple modules at once or none at all if one of
88them was not able to load. It also takes care of any error checking
89and so forth.
90
91=head1 Methods
92
93=head2 $href = check_install( module => NAME [, version => VERSION, verbose => BOOL ] );
94
95C<check_install> allows you to verify if a certain module is installed
96or not. You may call it with the following arguments:
97
98=over 4
99
100=item module
101
102The name of the module you wish to verify -- this is a required key
103
104=item version
105
106The version this module needs to be -- this is optional
107
108=item verbose
109
110Whether or not to be verbose about what it is doing -- it will default
111to $Module::Load::Conditional::VERBOSE
112
113=back
114
115It will return undef if it was not able to find where the module was
116installed, or a hash reference with the following keys if it was able
117to find the file:
118
119=over 4
120
121=item file
122
123Full path to the file that contains the module
124
125=item dir
126
127Directory, or more exact the C<@INC> entry, where the module was
128loaded from.
129
130=item version
131
132The version number of the installed module - this will be C<undef> if
133the module had no (or unparsable) version number, or if the variable
134C<$Module::Load::Conditional::FIND_VERSION> was set to true.
135(See the C<GLOBAL VARIABLES> section below for details)
136
137=item uptodate
138
139A boolean value indicating whether or not the module was found to be
140at least the version you specified. If you did not specify a version,
141uptodate will always be true if the module was found.
142If no parsable version was found in the module, uptodate will also be
143true, since C<check_install> had no way to verify clearly.
144
145See also C<$Module::Load::Conditional::DEPRECATED>, which affects
146the outcome of this value.
147
148=back
149
150=cut
151
152### this checks if a certain module is installed already ###
153### if it returns true, the module in question is already installed
154### or we found the file, but couldn't open it, OR there was no version
155### to be found in the module
156### it will return 0 if the version in the module is LOWER then the one
157### we are looking for, or if we couldn't find the desired module to begin with
158### if the installed version is higher or equal to the one we want, it will return
159### a hashref with he module name and version in it.. so 'true' as well.
160sub check_install {
161    my %hash = @_;
162
163    my $tmpl = {
164            version => { default    => '0.0'    },
165            module  => { required   => 1        },
166            verbose => { default    => $VERBOSE },
167    };
168
169    my $args;
170    unless( $args = check( $tmpl, \%hash, $VERBOSE ) ) {
171        warn loc( q[A problem occurred checking arguments] ) if $VERBOSE;
172        return;
173    }
174
175    my $file     = File::Spec->catfile( split /::/, $args->{module} ) . '.pm';
176    my $file_inc = File::Spec::Unix->catfile(
177                        split /::/, $args->{module}
178                    ) . '.pm';
179
180    ### where we store the return value ###
181    my $href = {
182            file        => undef,
183            version     => undef,
184            uptodate    => undef,
185    };
186
187    my $filename;
188
189    ### check the inc hash if we're allowed to
190    if( $CHECK_INC_HASH ) {
191        $filename = $href->{'file'} =
192            $INC{ $file_inc } if defined $INC{ $file_inc };
193
194        ### find the version by inspecting the package
195        if( defined $filename && $FIND_VERSION ) {
196            no strict 'refs';
197            $href->{version} = ${ "$args->{module}"."::VERSION" };
198        }
199    }
200
201    ### we didn't find the filename yet by looking in %INC,
202    ### so scan the dirs
203    unless( $filename ) {
204
205        local @INC = @INC[0..$#INC-1] if $FORCE_SAFE_INC && $INC[-1] eq '.';
206
207        DIR: for my $dir ( @INC ) {
208
209            my $fh;
210
211            if ( ref $dir ) {
212                ### @INC hook -- we invoke it and get the filehandle back
213                ### this is actually documented behaviour as of 5.8 ;)
214
215                my $existed_in_inc = $INC{$file_inc};
216
217                if (UNIVERSAL::isa($dir, 'CODE')) {
218                    ($fh) = $dir->($dir, $file);
219
220                } elsif (UNIVERSAL::isa($dir, 'ARRAY')) {
221                    ($fh) = $dir->[0]->($dir, $file, @{$dir}{1..$#{$dir}})
222
223                } elsif (UNIVERSAL::can($dir, 'INC')) {
224                    ($fh) = $dir->INC($file);
225                }
226
227                if (!UNIVERSAL::isa($fh, 'GLOB')) {
228                    warn loc(q[Cannot open file '%1': %2], $file, $!)
229                            if $args->{verbose};
230                    next;
231                }
232
233                $filename = $INC{$file_inc} || $file;
234
235                delete $INC{$file_inc} if not $existed_in_inc;
236
237            } else {
238                $filename = File::Spec->catfile($dir, $file);
239                next unless -e $filename;
240
241                $fh = new FileHandle;
242                if (!$fh->open($filename)) {
243                    warn loc(q[Cannot open file '%1': %2], $file, $!)
244                            if $args->{verbose};
245                    next;
246                }
247            }
248
249            ### store the directory we found the file in
250            $href->{dir} = $dir;
251
252            ### files need to be in unix format under vms,
253            ### or they might be loaded twice
254            $href->{file} = ON_VMS
255                ? VMS::Filespec::unixify( $filename )
256                : $filename;
257
258            ### if we don't need the version, we're done
259            last DIR unless $FIND_VERSION;
260
261            ### otherwise, the user wants us to find the version from files
262            my $mod_info = Module::Metadata->new_from_handle( $fh, $filename );
263            my $ver      = $mod_info->version( $args->{module} );
264
265            if( defined $ver ) {
266                $href->{version} = $ver;
267
268                last DIR;
269            }
270        }
271    }
272
273    ### if we couldn't find the file, return undef ###
274    return unless defined $href->{file};
275
276    ### only complain if we're expected to find a version higher than 0.0 anyway
277    if( $FIND_VERSION and not defined $href->{version} ) {
278        {   ### don't warn about the 'not numeric' stuff ###
279            local $^W;
280
281            ### if we got here, we didn't find the version
282            warn loc(q[Could not check version on '%1'], $args->{module} )
283                    if $args->{verbose} and $args->{version} > 0;
284        }
285        $href->{uptodate} = 1;
286
287    } else {
288        ### don't warn about the 'not numeric' stuff ###
289        local $^W;
290
291        ### use qv(), as it will deal with developer release number
292        ### ie ones containing _ as well. This addresses bug report
293        ### #29348: Version compare logic doesn't handle alphas?
294        ###
295        ### Update from JPeacock: apparently qv() and version->new
296        ### are different things, and we *must* use version->new
297        ### here, or things like #30056 might start happening
298
299        ### We have to wrap this in an eval as version-0.82 raises
300        ### exceptions and not warnings now *sigh*
301
302        eval {
303
304          $href->{uptodate} =
305            version->new( $args->{version} ) <= version->new( $href->{version} )
306                ? 1
307                : 0;
308
309        };
310    }
311
312    if ( $DEPRECATED and "$]" >= 5.011 ) {
313        local @INC = @INC[0..$#INC-1] if $FORCE_SAFE_INC && $INC[-1] eq '.';
314        require Module::CoreList;
315        require Config;
316
317        $href->{uptodate} = 0 if
318           exists $Module::CoreList::version{ 0+$] }{ $args->{module} } and
319           Module::CoreList::is_deprecated( $args->{module} ) and
320           $Config::Config{privlibexp} eq $href->{dir}
321           and $Config::Config{privlibexp} ne $Config::Config{sitelibexp};
322    }
323
324    return $href;
325}
326
327=head2 $bool = can_load( modules => { NAME => VERSION [,NAME => VERSION] }, [verbose => BOOL, nocache => BOOL, autoload => BOOL] )
328
329C<can_load> will take a list of modules, optionally with version
330numbers and determine if it is able to load them. If it can load *ALL*
331of them, it will. If one or more are unloadable, none will be loaded.
332
333This is particularly useful if you have More Than One Way (tm) to
334solve a problem in a program, and only wish to continue down a path
335if all modules could be loaded, and not load them if they couldn't.
336
337This function uses the C<load> function or the C<autoload_remote> function
338from Module::Load under the hood.
339
340C<can_load> takes the following arguments:
341
342=over 4
343
344=item modules
345
346This is a hashref of module/version pairs. The version indicates the
347minimum version to load. If no version is provided, any version is
348assumed to be good enough.
349
350=item verbose
351
352This controls whether warnings should be printed if a module failed
353to load.
354The default is to use the value of $Module::Load::Conditional::VERBOSE.
355
356=item nocache
357
358C<can_load> keeps its results in a cache, so it will not load the
359same module twice, nor will it attempt to load a module that has
360already failed to load before. By default, C<can_load> will check its
361cache, but you can override that by setting C<nocache> to true.
362
363=item autoload
364
365This controls whether imports the functions of a loaded modules to the caller package. The default is no importing any functions.
366
367See the C<autoload> function and the C<autoload_remote> function from L<Module::Load> for details.
368
369=cut
370
371sub can_load {
372    my %hash = @_;
373
374    my $tmpl = {
375        modules     => { default => {}, strict_type => 1 },
376        verbose     => { default => $VERBOSE },
377        nocache     => { default => 0 },
378        autoload    => { default => 0 },
379    };
380
381    my $args;
382
383    unless( $args = check( $tmpl, \%hash, $VERBOSE ) ) {
384        $ERROR = loc(q[Problem validating arguments!]);
385        warn $ERROR if $VERBOSE;
386        return;
387    }
388
389    ### layout of $CACHE:
390    ### $CACHE = {
391    ###     $ module => {
392    ###             usable  => BOOL,
393    ###             version => \d,
394    ###             file    => /path/to/file,
395    ###     },
396    ### };
397
398    $CACHE ||= {}; # in case it was undef'd
399
400    my $error;
401    BLOCK: {
402        my $href = $args->{modules};
403
404        my @load;
405        for my $mod ( keys %$href ) {
406
407            next if $CACHE->{$mod}->{usable} && !$args->{nocache};
408
409            ### else, check if the hash key is defined already,
410            ### meaning $mod => 0,
411            ### indicating UNSUCCESSFUL prior attempt of usage
412
413            ### use qv(), as it will deal with developer release number
414            ### ie ones containing _ as well. This addresses bug report
415            ### #29348: Version compare logic doesn't handle alphas?
416            ###
417            ### Update from JPeacock: apparently qv() and version->new
418            ### are different things, and we *must* use version->new
419            ### here, or things like #30056 might start happening
420            if (    !$args->{nocache}
421                    && defined $CACHE->{$mod}->{usable}
422                    && (version->new( $CACHE->{$mod}->{version}||0 )
423                        >= version->new( $href->{$mod} ) )
424            ) {
425                $error = loc( q[Already tried to use '%1', which was unsuccessful], $mod);
426                last BLOCK;
427            }
428
429            my $mod_data = check_install(
430                                    module  => $mod,
431                                    version => $href->{$mod}
432                                );
433
434            if( !$mod_data or !defined $mod_data->{file} ) {
435                $error = loc(q[Could not find or check module '%1'], $mod);
436                $CACHE->{$mod}->{usable} = 0;
437                last BLOCK;
438            }
439
440            map {
441                $CACHE->{$mod}->{$_} = $mod_data->{$_}
442            } qw[version file uptodate];
443
444            push @load, $mod;
445        }
446
447        for my $mod ( @load ) {
448
449            if ( $CACHE->{$mod}->{uptodate} ) {
450
451                local @INC = @INC[0..$#INC-1] if $FORCE_SAFE_INC && $INC[-1] eq '.';
452
453                if ( $args->{autoload} ) {
454                    my $who = (caller())[0];
455                    eval { autoload_remote $who, $mod };
456                } else {
457                    eval { load $mod };
458                }
459
460                ### in case anything goes wrong, log the error, the fact
461                ### we tried to use this module and return 0;
462                if( $@ ) {
463                    $error = $@;
464                    $CACHE->{$mod}->{usable} = 0;
465                    last BLOCK;
466                } else {
467                    $CACHE->{$mod}->{usable} = 1;
468                }
469
470            ### module not found in @INC, store the result in
471            ### $CACHE and return 0
472            } else {
473
474                $error = loc(q[Module '%1' is not uptodate!], $mod);
475                $CACHE->{$mod}->{usable} = 0;
476                last BLOCK;
477            }
478        }
479
480    } # BLOCK
481
482    if( defined $error ) {
483        $ERROR = $error;
484        Carp::carp( loc(q|%1 [THIS MAY BE A PROBLEM!]|,$error) ) if $args->{verbose};
485        return;
486    } else {
487        return 1;
488    }
489}
490
491=back
492
493=head2 @list = requires( MODULE );
494
495C<requires> can tell you what other modules a particular module
496requires. This is particularly useful when you're intending to write
497a module for public release and are listing its prerequisites.
498
499C<requires> takes but one argument: the name of a module.
500It will then first check if it can actually load this module, and
501return undef if it can't.
502Otherwise, it will return a list of modules and pragmas that would
503have been loaded on the module's behalf.
504
505Note: The list C<require> returns has originated from your current
506perl and your current install.
507
508=cut
509
510sub requires {
511    my $who = shift;
512
513    unless( check_install( module => $who ) ) {
514        warn loc(q[You do not have module '%1' installed], $who) if $VERBOSE;
515        return undef;
516    }
517
518    local @INC = @INC[0..$#INC-1] if $FORCE_SAFE_INC && $INC[-1] eq '.';
519
520    my $lib = join " ", map { qq["-I$_"] } @INC;
521    my $oneliner = 'print(join(qq[\n],map{qq[BONG=$_]}keys(%INC)),qq[\n])';
522    my $cmd = join '', qq["$^X" $lib -M$who -e], QUOTE, $oneliner, QUOTE;
523
524    return  sort
525                grep { !/^$who$/  }
526                map  { chomp; s|/|::|g; $_ }
527                grep { s|\.pm$||i; }
528                map  { s!^BONG\=!!; $_ }
529                grep { m!^BONG\=! }
530            `$cmd`;
531}
532
5331;
534
535__END__
536
537=head1 Global Variables
538
539The behaviour of Module::Load::Conditional can be altered by changing the
540following global variables:
541
542=head2 $Module::Load::Conditional::VERBOSE
543
544This controls whether Module::Load::Conditional will issue warnings and
545explanations as to why certain things may have failed. If you set it
546to 0, Module::Load::Conditional will not output any warnings.
547The default is 0;
548
549=head2 $Module::Load::Conditional::FIND_VERSION
550
551This controls whether Module::Load::Conditional will try to parse
552(and eval) the version from the module you're trying to load.
553
554If you don't wish to do this, set this variable to C<false>. Understand
555then that version comparisons are not possible, and Module::Load::Conditional
556can not tell you what module version you have installed.
557This may be desirable from a security or performance point of view.
558Note that C<$FIND_VERSION> code runs safely under C<taint mode>.
559
560The default is 1;
561
562=head2 $Module::Load::Conditional::CHECK_INC_HASH
563
564This controls whether C<Module::Load::Conditional> checks your
565C<%INC> hash to see if a module is available. By default, only
566C<@INC> is scanned to see if a module is physically on your
567filesystem, or available via an C<@INC-hook>. Setting this variable
568to C<true> will trust any entries in C<%INC> and return them for
569you.
570
571The default is 0;
572
573=head2 $Module::Load::Conditional::FORCE_SAFE_INC
574
575This controls whether C<Module::Load::Conditional> sanitises C<@INC>
576by removing "C<.>". The current default setting is C<0>, but this
577may change in a future release.
578
579=head2 $Module::Load::Conditional::CACHE
580
581This holds the cache of the C<can_load> function. If you explicitly
582want to remove the current cache, you can set this variable to
583C<undef>
584
585=head2 $Module::Load::Conditional::ERROR
586
587This holds a string of the last error that happened during a call to
588C<can_load>. It is useful to inspect this when C<can_load> returns
589C<undef>.
590
591=head2 $Module::Load::Conditional::DEPRECATED
592
593This controls whether C<Module::Load::Conditional> checks if
594a dual-life core module has been deprecated. If this is set to
595true C<check_install> will return false to C<uptodate>, if
596a dual-life module is found to be loaded from C<$Config{privlibexp}>
597
598The default is 0;
599
600=head1 See Also
601
602C<Module::Load>
603
604=head1 BUG REPORTS
605
606Please report bugs or other issues to E<lt>bug-module-load-conditional@rt.cpan.orgE<gt>.
607
608=head1 AUTHOR
609
610This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
611
612=head1 COPYRIGHT
613
614This library is free software; you may redistribute and/or modify it
615under the same terms as Perl itself.
616
617=cut
618