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