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