File Coverage

blib/lib/Module/Install/GetProgramLocations.pm
Criterion Covered Total %
statement 65 195 33.3
branch 12 72 16.6
condition 8 21 38.1
subroutine 12 19 63.1
pod 4 4 100.0
total 101 311 32.4


line stmt bran cond sub pod time code
1             package Module::Install::GetProgramLocations;
2              
3 3     3   163358 use strict;
  3         24  
  3         86  
4 3     3   91 use 5.005;
  3         12  
5              
6 3     3   18 use Config;
  3         4  
  3         162  
7 3     3   13 use Cwd;
  3         16  
  3         245  
8 3     3   31 use Carp;
  3         10  
  3         219  
9 3     3   14 use File::Spec;
  3         5  
  3         57  
10 3     3   1138 use Sort::Versions;
  3         1694  
  3         430  
11 3     3   17 use Exporter();
  3         4  
  3         47  
12              
13 3     3   12 use vars qw( @ISA $VERSION @EXPORT );
  3         4  
  3         190  
14              
15 3     3   1066 use Module::Install::Base;
  3         1509  
  3         3406  
16             @ISA = qw( Module::Install::Base Exporter );
17              
18             @EXPORT = qw( &get_gnu_version
19             &get_bzip2_version
20             );
21              
22             $VERSION = sprintf "%d.%02d%02d", q/0.30.12/ =~ /(\d+)/g;
23              
24             # ---------------------------------------------------------------------------
25              
26             sub get_program_locations
27             {
28 0     0 1 0 my $self = shift;
29 0         0 my %info = %{ shift @_ };
  0         0  
30              
31 0         0 foreach my $program (keys %info)
32             {
33             croak "argname is required for $program"
34 0 0       0 unless defined $info{$program}{'argname'};
35              
36 0 0       0 if (exists $info{$program}{'types'}) {
37 0         0 foreach my $type (keys %{ $info{$program}{'types'} }) {
  0         0  
38 0 0       0 next unless exists $info{$program}{'types'}{$type}{'fetch'};
39              
40             croak "Fetch routine must be a valid code reference"
41             unless ref $info{$program}{'types'}{$type}{'fetch'} eq "CODE" &&
42 0 0 0     0 defined &{ $info{$program}{'types'}{$type}{'fetch'} };
  0         0  
43             }
44             }
45             }
46              
47 0         0 $self->include_deps('Config',0);
48 0         0 $self->include_deps('File::Spec',0);
49 0         0 $self->include_deps('Sort::Versions',0);
50 0         0 $self->include_deps('Cwd',0);
51              
52 0         0 my %user_specified_program_paths =
53             $self->_get_user_specified_program_locations(\%info);
54              
55 0 0       0 if (keys %user_specified_program_paths)
56             {
57 0         0 return $self->_get_argv_program_locations(\%info,
58             \%user_specified_program_paths);
59             }
60             else
61             {
62 0         0 return $self->_prompt_user_for_program_locations(\%info);
63             }
64             }
65              
66             # ---------------------------------------------------------------------------
67              
68             sub _get_user_specified_program_locations
69             {
70 0     0   0 my $self = shift;
71 0         0 my %info = %{ shift @_ };
  0         0  
72              
73 0         0 my %user_specified_program_paths;
74             my @remaining_args;
75              
76             # Look for user-provided paths in @ARGV
77 0         0 foreach my $arg (@ARGV)
78             {
79 0         0 my ($var,$value) = $arg =~ /^(.*?)=(.*)$/;
80              
81 0 0       0 push(@remaining_args, $arg), next unless defined $var;
82              
83 0 0       0 $value = undef if $value eq '';
84              
85 0         0 my $is_a_program_arg = 0;
86              
87 0         0 foreach my $program (keys %info)
88             {
89 0 0       0 if ($var eq $info{$program}{'argname'})
90             {
91 0         0 $user_specified_program_paths{$program} = $value;
92 0         0 $is_a_program_arg = 1;
93 0         0 last;
94             }
95             }
96              
97 0 0       0 push @remaining_args, $arg unless $is_a_program_arg;
98             }
99              
100 0         0 @ARGV = @remaining_args;
101              
102 0         0 return %user_specified_program_paths;
103             }
104              
105             # ---------------------------------------------------------------------------
106              
107             sub _get_argv_program_locations
108             {
109 0     0   0 my $self = shift;
110 0         0 my %info = %{ shift @_ };
  0         0  
111 0         0 my %program_locations = %{ shift @_ };
  0         0  
112              
113 0         0 my %program_info;
114              
115 0         0 foreach my $program_name (sort keys %info)
116             {
117 0         0 $program_info{$program_name} =
118             { 'path' => undef, 'type' => undef, 'version' => undef };
119              
120             next if exists $program_locations{$program_name} &&
121 0 0 0     0 $program_locations{$program_name} eq '';
122              
123             $program_locations{$program_name} = $info{$program_name}{'default'}
124 0 0       0 unless exists $program_locations{$program_name};
125              
126 0         0 my $full_path = $self->_Make_Absolute($program_locations{$program_name});
127 0 0       0 if (!defined $self->can_run($full_path))
128             {
129 0         0 warn "\"$full_path\" does not appear to be a valid executable\n";
130 0         0 warn "Using anyway\n";
131              
132 0         0 $program_info{$program_name} =
133             { path => $full_path, type => undef, version => undef };
134             }
135             else
136             {
137 0         0 my ($is_valid,$type,$version) =
138             $self->_program_version_is_valid($program_name,$full_path,\%info);
139            
140 0 0       0 unless($is_valid)
141             {
142 0         0 warn "\"$full_path\" is not a correct version\n";
143 0         0 warn "Using anyway\n";
144             }
145              
146 0         0 $program_info{$program_name} =
147             { path => $full_path, type => $type, version => $version };
148             }
149             }
150              
151 0         0 return %program_info;
152             }
153              
154             # ---------------------------------------------------------------------------
155              
156             sub _prompt_user_for_program_locations
157             {
158 0     0   0 my $self = shift;
159 0         0 my %info = %{ shift @_ };
  0         0  
160              
161             # Force the include inc/Module/Install/Can.pm message to appear early
162 0         0 $self->can_run();
163              
164 0         0 print "Enter the full path, or \"none\" for none.\n";
165              
166 0         0 my $last_choice = '';
167              
168 0         0 my %program_info;
169              
170 0         0 ASK: foreach my $program_name (sort keys %info)
171             {
172 0         0 my ($name,$full_path);
173              
174             # Convert any default to a full path, initially
175 0         0 $name = $Config{$program_name};
176 0         0 $full_path = $self->can_run($name);
177              
178 0 0 0     0 if ($name eq '' || !defined $full_path)
179             {
180 0         0 $name = $info{$program_name}{'default'};
181 0         0 $full_path = $self->can_run($name);
182             }
183              
184 0 0 0     0 $full_path = 'none' if !defined $full_path || $name eq '';
185              
186 0         0 my $allowed_types = '';
187 0 0       0 if (exists $info{$program_name}{'types'})
188             {
189 0         0 foreach my $type (keys %{ $info{$program_name}{'types'} } )
  0         0  
190             {
191 0         0 $allowed_types .= ", $type";
192             }
193              
194 0         0 $allowed_types =~ s/^, //;
195 0         0 $allowed_types =~ s/(.*), /$1, or /;
196 0         0 $allowed_types = " ($allowed_types";
197 0 0       0 $allowed_types .= scalar(keys %{ $info{$program_name}{'types'} }) > 1 ?
  0         0  
198             " types)" : " type)";
199             }
200              
201 0         0 my $choice = $self->prompt(
202             "Where can I find your \"$program_name\" executable?" .
203             "$allowed_types", $full_path);
204              
205 0 0       0 $program_info{$program_name} =
206             { path => undef, type => undef, version => undef }, next
207             if $choice eq 'none';
208              
209 0         0 $choice = $self->_Make_Absolute($choice);
210              
211 0 0       0 if (!defined $self->can_run($choice))
212             {
213 0         0 warn "\"$choice\" does not appear to be a valid executable\n";
214              
215 0 0       0 if ($last_choice ne $choice)
216             {
217 0         0 $last_choice = $choice;
218 0         0 redo ASK;
219             }
220              
221 0         0 warn "Using anyway\n";
222             }
223             else
224             {
225 0         0 my ($is_valid,$type,$version) =
226             $self->_program_version_is_valid($program_name,$choice,\%info);
227            
228 0 0       0 if(!$is_valid)
229             {
230 0         0 warn "\"$choice\" is not a correct version\n";
231              
232 0 0       0 if ($last_choice ne $choice)
233             {
234 0         0 $last_choice = $choice;
235 0         0 redo ASK;
236             }
237              
238 0         0 warn "Using anyway\n";
239             }
240              
241 0         0 $program_info{$program_name} =
242             { path => $choice, type => $type, version => $version };
243             }
244             }
245              
246 0         0 return %program_info;
247             }
248              
249             # ---------------------------------------------------------------------------
250              
251             sub _program_version_is_valid
252             {
253 2     2   596 my $self = shift;
254 2         4 my $program_name = shift;
255 2         12 my $program = shift;
256 2         4 my %info = %{ shift @_ };
  2         8  
257              
258 2 50       7 if (exists $info{$program_name}{'types'})
259             {
260 2         2 my $version;
261              
262 2         4 TYPE: foreach my $type (keys %{$info{$program_name}{'types'}})
  2         5  
263             {
264 2         4 $version = &{$info{$program_name}{'types'}{$type}{'fetch'}}($program);
  2         6  
265              
266 2 50       7664 next TYPE unless defined $version;
267              
268 2 100       40 if ($self->version_matches_range($version,
269             $info{$program_name}{'types'}{$type}{'numbers'}))
270             {
271 1         20 return (1,$type,$version);
272             }
273             }
274              
275 1         15 my $version_string = '';
276 1 50       13 $version_string = $version if defined $version;
277 1         42 warn "\"$program\" version $version_string is not valid for any of the following:\n";
278              
279 1         14 foreach my $type (keys %{$info{$program_name}{'types'}})
  1         9  
280             {
281             warn " $type => " .
282 1         12 $info{$program_name}{'types'}{$type}{'numbers'} . "\n";
283             }
284              
285 1         24 return (0,undef,undef);
286             }
287              
288 0         0 return (1,undef,undef);
289             }
290              
291             # ---------------------------------------------------------------------------
292              
293             sub version_matches_range
294             {
295 9     9 1 602 my $self = shift;
296 9         19 my $version = shift;
297 9         19 my $version_specification = shift;
298              
299 9         30 my $range_pattern = '([\[\(].*?\s*,\s*.*?[\]\)])';
300              
301 9         98 my @ranges = $version_specification =~ /$range_pattern/g;
302              
303 9 50       23 die "Version specification \"$version_specification\" is incorrect\n"
304             unless @ranges;
305              
306 9         23 foreach my $range (@ranges)
307             {
308 11         57 my ($lower_bound,$lower_version,$upper_version,$upper_bound) =
309             ( $range =~ /([\[\(])(.*?)\s*,\s*(.*?)([\]\)])/ );
310 11 100       32 $lower_bound = '>' . ( $lower_bound eq '[' ? '=' : '');
311 11 100       25 $upper_bound = '<' . ( $upper_bound eq ']' ? '=' : '');
312              
313 11         14 my ($lower_bound_satisified, $upper_bound_satisified);
314              
315 11   100     52 $lower_bound_satisified =
316             ($lower_version eq '' || versioncmp($version,$lower_version) == 1 ||
317             ($lower_bound eq '>=' && versioncmp($version,$lower_version) == 0));
318 11   66     543 $upper_bound_satisified =
319             ($upper_version eq '' || versioncmp($version,$upper_version) == -1 ||
320             ($upper_bound eq '<=' && versioncmp($version,$upper_version) == 0));
321              
322 11 100 100     349 return 1 if $lower_bound_satisified && $upper_bound_satisified;
323             }
324              
325 3         13 return 0;
326             }
327              
328             # ---------------------------------------------------------------------------
329              
330             # Returns the original if the full path can't be found
331             sub _Make_Absolute
332             {
333 0     0     my $self = shift;
334 0           my $program = shift;
335              
336 0 0         if(File::Spec->file_name_is_absolute($program))
337             {
338 0           return $program;
339             }
340             else
341             {
342 0           my $path_to_choice = undef;
343              
344 0           foreach my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), cwd())
345             {
346 0           $path_to_choice = File::Spec->catfile($dir, $program);
347 0 0         last if defined $self->can_run($path_to_choice);
348             }
349              
350 0 0         return $program unless -e $path_to_choice;
351              
352 0           warn "WARNING: Avoiding security risks by converting to absolute paths\n";
353 0           warn "\"$program\" is currently in your path at \"$path_to_choice\"\n";
354              
355 0           return $path_to_choice;
356             }
357             }
358              
359             # ---------------------------------------------------------------------------
360              
361             sub get_gnu_version
362             {
363 0     0 1   my $program = shift;
364              
365 0 0         die "Missing GNU program to get version for" unless defined $program;
366              
367 0           my $version_message;
368              
369             # Newer versions
370             {
371 0           my $command = "\"$program\" --version 2>" . File::Spec->devnull();
  0            
372 0           $version_message = `$command`;
373             }
374              
375             # Older versions use -V
376 0 0         unless($version_message =~ /\b(GNU|Free\s+Software\s+Foundation)\b/s)
377             {
378 0           my $command = "\"$program\" -V 2>&1 1>" . File::Spec->devnull();
379 0           $version_message = `$command`;
380             }
381              
382             return undef unless ## no critic (ProhibitExplicitReturnUndef)
383 0 0         $version_message =~ /\b(GNU|Free\s+Software\s+Foundation)\b/s;
384              
385 0           my ($program_version) = $version_message =~ /^.*?([\d]+\.[\d.a-z]+)/s;
386              
387 0           return $program_version;
388             }
389              
390             # ---------------------------------------------------------------------------
391              
392             sub get_bzip2_version
393             {
394 0     0 1   my $program = shift;
395              
396 0           my $command = "\"$program\" --help 2>&1 1>" . File::Spec->devnull();
397 0           my $version_message = `$command`;
398              
399 0           my ($program_version) = $version_message =~ /^.*?([\d]+\.[\d.a-z]+)/s;
400              
401 0           return $program_version;
402             }
403              
404             1;
405              
406             # ---------------------------------------------------------------------------
407              
408             =head1 NAME
409              
410             Module::Install::GetProgramLocations - A Module::Install extension that allows the user to interactively specify the location of programs needed by the module to be installed
411              
412              
413             =head1 SYNOPSIS
414              
415             A simple example:
416              
417             use inc::Module::Install;
418             ...
419             my %info = (
420             # No default, and can't specify it on the command line
421             'diff' => {},
422             # A full path default and a command line variable
423             'grep' => { default => '/usr/bin/grep', argname => 'GREP' },
424             # A no-path default and a command line variable
425             'gzip' => { default => 'gzip', argname => 'GZIP' },
426             );
427              
428             my %location_info = get_program_locations(\%info);
429              
430             print "grep path is " . $location_info{'grep'}{'path'} . "\n";
431              
432             A complex example showing all the bells and whistles:
433              
434             use inc::Module::Install;
435             ...
436             # User-defined get version program
437             sub get_solaris_grep_version
438             {
439             my $program = shift;
440              
441             my $result = `strings $program | $program SUNW_OST_OSCMD`;
442              
443             return undef unless $result =~ /SUNW_OST_OSCMD/;
444              
445             # Solaris grep isn't versioned, so we'll just return 0 for it
446             return 0;
447             }
448              
449             my %info = (
450             # Either the GNU or the Solaris version
451             'grep' => { default => 'grep', argname => 'GREP',
452             type => {
453             # Any GNU version higher than 2.1
454             'GNU' => { fetch => \&get_gnu_version,
455             numbers => '[2.1,)', },
456             # Any solaris version
457             'Solaris' => { fetch => \&get_solaris_grep_version,
458             numbers => '[0,)', },
459             },
460             },
461             );
462              
463             my %location_info = get_program_locations(\%info);
464              
465             print "grep path is " . $location_info{'grep'}{'path'} . "\n";
466             print "grep type is " . $location_info{'grep'}{'type'} . "\n";
467             print "grep version is " . $location_info{'grep'}{'version'} . "\n";
468              
469              
470             =head1 DESCRIPTION
471              
472             If you are installing a module that calls external programs, it's best to make
473             sure that those programs are installed and working correctly. This
474             Module::Install extension helps with that process. Given a specification of
475             the required programs, it attempts to find a working version on the system
476             based on the Perl configuration and the user's path. The extension then
477             returns a hash mapping the program names to a hash containing the absolute
478             path to the program, the type, and the version number. (It's best to use the
479             absolute path in order to avoid security problems.)
480              
481             The program specification allows the user to specify a default program, a
482             command-line name for the program to be set, and multiple types of satisfying
483             implementations of the program. For the types, the user can specify a function
484             to extract the version, and a version range to check the version.
485              
486             The extension defaults to interactive mode, where it asks the user to specify
487             the paths to the programs. If the user specifies a relative path, the
488             extension converts this to an absolute path. The user can specify
489             "none", in which case the hash values will be undefined. Similarly, if the , or if the type or version cannot be determined, then the
490             hash values will be undefined.
491              
492             The extension also supports a noninteractive mode, where the programs are
493             provided on the command line. For example, "perl Makefile.PL
494             PROGRAM=" is used on the command line to indicate the desired
495             program. The path is converted to an absolute path. "" can be empty
496             to indicate that it is not available.
497              
498             This extension will perform validation on the program, whether or not it was
499             specified interactively. It makes sure that the program can be run, and will
500             optionally check the version for correctness if the user provides that
501             information. If the program can't be run or is the wrong version, an error
502             message is displayed. In interactive mode, the user is prompted again. If the
503             user enters the same information twice, then the information is used
504             regardless of any problems. In noninteractive mode, the program is used
505             anyway.
506              
507             =head1 METHODS
508              
509             =over 4
510              
511             =item get_program_locations(EHASH REFE)
512              
513             This function takes as input a hash with information for the programs to be
514             found, and returns a hash representing program location data. The keys of the
515             argument hash are the program names (and can actually be anything). The values
516             are named:
517              
518             =over 2
519              
520             =item default
521              
522             The default program. This can be non-absolute, in which case the user's PATH
523             is searched. For example, you might specify "bzip2" as a default for the
524             "bzip" program because bzip2 can unpack older bzip archives.
525              
526             =item argname
527              
528             The command line variable name. For example, if you want the user to be able
529             to set the path to bzip2, you might set this to "BZIP2" so that the user can
530             run "perl Makefile.PL BZIP2=/usr/bin/bzip2".
531              
532             =item types
533              
534             A hash mapping a descriptive version name to a hash containing a mapping for
535             two keys:
536              
537             =over 2
538              
539             =item fetch
540              
541             Specifies a subroutine that takes the program path as an argument, and returns
542             either undef (if the program is not correct) or a version number.
543              
544             =item numbers
545              
546             A string containing allowed version ranges. Ranges are specified using
547             interval notation. That is "[1,2)" indicates versions between 1 and 2,
548             including 1 but not 2. Any characters can separate ranges, although you'd best
549             not use any of "[]()" in order to avoid confusing the module.
550              
551             This module uses the Sort::Versions module for comparing version numbers. See
552             that module for a summary of version string syntax, and an explanation of how
553             they compare.
554              
555             =back
556              
557             Each of your fetch routines should only succeed for one kind of
558             implementation, returning undef when they fail.
559              
560             =back
561              
562             The return value for get_program_locations is a hash whose keys are the same
563             as those of %info, and whose values are hashes having three values:
564              
565             =over 2
566              
567             =item path
568              
569             The absolute path to the program. This value is undef if the user chose no
570             program.
571              
572             =item type
573              
574             The name of the type, if there are multiple possible types. This name
575             corresponds to the name originally given in the "types" hash. This value is
576             undef if no program was chosen by the user, or if there was no types hash
577             value.
578              
579             =item version
580              
581             The version number of the program.
582              
583             =back
584              
585              
586             =item version_matches_range(EPROGRAM VERSIONE, ERANGEE);
587              
588             This function takes a program version string and a version ranges specification
589             and returns true if the program version is in any of the ranges. For example
590             '1.2.3a' is in the second range of '[1.0,1.1) (1.2.3,)' because 1.2.3a is
591             higher than 1.2.3, but less than infinity.
592              
593             =back
594              
595             =head1 VERSIONING METHODS
596              
597             This module provides some functions for extracting the version number from
598             common programs. They are exported by default into the caller's namespace.
599             Feel free to submit new version functions for programs that you use.
600              
601             =over 4
602              
603             =item $version = get_gnu_version(EPATH TO PROGRAME)
604              
605             Gets the version of a general GNU program. Returns undef if the application
606             does not appear to be a GNU application. This function relies on certain
607             conventions that the Free Software Foundation uses for printing the version of
608             GNU applications. It may not work for all programs.
609              
610             =item $version = get_bzip2_version($path_to_program)
611              
612             Gets the version of bzip2.
613              
614             =back
615              
616             =head1 LICENSE
617              
618             This code is distributed under the GNU General Public License (GPL) Version 2.
619             See the file LICENSE in the distribution for details.
620              
621             =head1 AUTHOR
622              
623             David Coppit Edavid@coppit.orgE
624              
625             =head1 SEE ALSO
626              
627             L
628              
629             =cut