Add new_from_handle method [RT #68875]
[p5sagit/Module-Metadata.git] / lib / Module / Metadata.pm
1 # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
2 # vim:ts=8:sw=2:et:sta:sts=2
3 package Module::Metadata;
4
5 # Adapted from Perl-licensed code originally distributed with
6 # Module-Build by Ken Williams
7
8 # This module provides routines to gather information about
9 # perl modules (assuming this may be expanded in the distant
10 # parrot future to look at other types of modules).
11
12 use strict;
13 use vars qw($VERSION);
14 $VERSION = '1.000005';
15 $VERSION = eval $VERSION;
16
17 use File::Spec;
18 use IO::File;
19 use version 0.87;
20 BEGIN {
21   if ($INC{'Log/Contextual.pm'}) {
22     Log::Contextual->import('log_info');
23   } else {
24     *log_info = sub (&) { warn $_[0]->() };
25   }
26 }
27 use File::Find qw(find);
28
29 my $V_NUM_REGEXP = qr{v?[0-9._]+};  # crudely, a v-string or decimal
30
31 my $PKG_REGEXP  = qr{   # match a package declaration
32   ^[\s\{;]*             # intro chars on a line
33   package               # the word 'package'
34   \s+                   # whitespace
35   ([\w:]+)              # a package name
36   \s*                   # optional whitespace
37   ($V_NUM_REGEXP)?        # optional version number
38   \s*                   # optional whitesapce
39   ;                     # semicolon line terminator
40 }x;
41
42 my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
43   ([\$*])         # sigil - $ or *
44   (
45     (             # optional leading package name
46       (?:::|\')?  # possibly starting like just :: (Ì  la $::VERSION)
47       (?:\w+(?:::|\'))*  # Foo::Bar:: ...
48     )?
49     VERSION
50   )\b
51 }x;
52
53 my $VERS_REGEXP = qr{ # match a VERSION definition
54   (?:
55     \(\s*$VARNAME_REGEXP\s*\) # with parens
56   |
57     $VARNAME_REGEXP           # without parens
58   )
59   \s*
60   =[^=~]  # = but not ==, nor =~
61 }x;
62
63
64 sub new_from_file {
65   my $class    = shift;
66   my $filename = File::Spec->rel2abs( shift );
67
68   return undef unless defined( $filename ) && -f $filename;
69   return $class->_init(undef, $filename, @_);
70 }
71
72 sub new_from_handle {
73   my $class    = shift;
74   my $handle   = shift;
75   my $filename = shift;
76   return undef unless defined($handle) && defined($filename);
77   $filename = File::Spec->rel2abs( $filename );
78
79   return $class->_init(undef, $filename, @_, handle => $handle);
80
81 }
82
83
84 sub new_from_module {
85   my $class   = shift;
86   my $module  = shift;
87   my %props   = @_;
88
89   $props{inc} ||= \@INC;
90   my $filename = $class->find_module_by_name( $module, $props{inc} );
91   return undef unless defined( $filename ) && -f $filename;
92   return $class->_init($module, $filename, %props);
93 }
94
95 {
96   
97   my $compare_versions = sub {
98     my ($v1, $op, $v2) = @_;
99     $v1 = version->new($v1)
100       unless UNIVERSAL::isa($v1,'version');
101   
102     my $eval_str = "\$v1 $op \$v2";
103     my $result   = eval $eval_str;
104     log_info { "error comparing versions: '$eval_str' $@" } if $@;
105   
106     return $result;
107   };
108
109   my $normalize_version = sub {
110     my ($version) = @_;
111     if ( $version =~ /[=<>!,]/ ) { # logic, not just version
112       # take as is without modification
113     }
114     elsif ( ref $version eq 'version' ) { # version objects
115       $version = $version->is_qv ? $version->normal : $version->stringify;
116     }
117     elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
118       # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
119       $version = "v$version";
120     }
121     else {
122       # leave alone
123     }
124     return $version;
125   };
126
127   # separate out some of the conflict resolution logic
128
129   my $resolve_module_versions = sub {
130     my $packages = shift;
131   
132     my( $file, $version );
133     my $err = '';
134       foreach my $p ( @$packages ) {
135         if ( defined( $p->{version} ) ) {
136         if ( defined( $version ) ) {
137           if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
138             $err .= "  $p->{file} ($p->{version})\n";
139           } else {
140             # same version declared multiple times, ignore
141           }
142         } else {
143           $file    = $p->{file};
144           $version = $p->{version};
145         }
146         }
147         $file ||= $p->{file} if defined( $p->{file} );
148       }
149   
150     if ( $err ) {
151       $err = "  $file ($version)\n" . $err;
152     }
153   
154     my %result = (
155       file    => $file,
156       version => $version,
157       err     => $err
158     );
159   
160     return \%result;
161   };
162
163   sub package_versions_from_directory {
164     my ( $class, $dir, $files ) = @_;
165
166     my @files;
167
168     if ( $files ) {
169       @files = @$files;
170     } else {
171       find( {
172         wanted => sub {
173           push @files, $_ if -f $_ && /\.pm$/;
174         },
175         no_chdir => 1,
176       }, $dir );
177     }
178
179     # First, we enumerate all packages & versions,
180     # separating into primary & alternative candidates
181     my( %prime, %alt );
182     foreach my $file (@files) {
183       my $mapped_filename = File::Spec->abs2rel( $file, $dir );
184       my @path = split( /\//, $mapped_filename );
185       (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
186   
187       my $pm_info = $class->new_from_file( $file );
188   
189       foreach my $package ( $pm_info->packages_inside ) {
190         next if $package eq 'main';  # main can appear numerous times, ignore
191         next if $package eq 'DB';    # special debugging package, ignore
192         next if grep /^_/, split( /::/, $package ); # private package, ignore
193   
194         my $version = $pm_info->version( $package );
195   
196         if ( $package eq $prime_package ) {
197           if ( exists( $prime{$package} ) ) {
198             die "Unexpected conflict in '$package'; multiple versions found.\n";
199           } else {
200             $prime{$package}{file} = $mapped_filename;
201             $prime{$package}{version} = $version if defined( $version );
202           }
203         } else {
204           push( @{$alt{$package}}, {
205                                     file    => $mapped_filename,
206                                     version => $version,
207                                    } );
208         }
209       }
210     }
211   
212     # Then we iterate over all the packages found above, identifying conflicts
213     # and selecting the "best" candidate for recording the file & version
214     # for each package.
215     foreach my $package ( keys( %alt ) ) {
216       my $result = $resolve_module_versions->( $alt{$package} );
217   
218       if ( exists( $prime{$package} ) ) { # primary package selected
219   
220         if ( $result->{err} ) {
221         # Use the selected primary package, but there are conflicting
222         # errors among multiple alternative packages that need to be
223         # reported
224           log_info {
225             "Found conflicting versions for package '$package'\n" .
226             "  $prime{$package}{file} ($prime{$package}{version})\n" .
227             $result->{err}
228           };
229   
230         } elsif ( defined( $result->{version} ) ) {
231         # There is a primary package selected, and exactly one
232         # alternative package
233   
234         if ( exists( $prime{$package}{version} ) &&
235              defined( $prime{$package}{version} ) ) {
236           # Unless the version of the primary package agrees with the
237           # version of the alternative package, report a conflict
238           if ( $compare_versions->(
239                  $prime{$package}{version}, '!=', $result->{version}
240                )
241              ) {
242
243             log_info {
244               "Found conflicting versions for package '$package'\n" .
245               "  $prime{$package}{file} ($prime{$package}{version})\n" .
246               "  $result->{file} ($result->{version})\n"
247             };
248           }
249   
250         } else {
251           # The prime package selected has no version so, we choose to
252           # use any alternative package that does have a version
253           $prime{$package}{file}    = $result->{file};
254           $prime{$package}{version} = $result->{version};
255         }
256   
257         } else {
258         # no alt package found with a version, but we have a prime
259         # package so we use it whether it has a version or not
260         }
261   
262       } else { # No primary package was selected, use the best alternative
263   
264         if ( $result->{err} ) {
265           log_info {
266             "Found conflicting versions for package '$package'\n" .
267             $result->{err}
268           };
269         }
270   
271         # Despite possible conflicting versions, we choose to record
272         # something rather than nothing
273         $prime{$package}{file}    = $result->{file};
274         $prime{$package}{version} = $result->{version}
275           if defined( $result->{version} );
276       }
277     }
278   
279     # Normalize versions.  Can't use exists() here because of bug in YAML::Node.
280     # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
281     for (grep defined $_->{version}, values %prime) {
282       $_->{version} = $normalize_version->( $_->{version} );
283     }
284   
285     return \%prime;
286   }
287
288   
289
290 sub _init {
291   my $class    = shift;
292   my $module   = shift;
293   my $filename = shift;
294   my %props = @_;
295
296   my $handle = delete $props{handle};
297   my( %valid_props, @valid_props );
298   @valid_props = qw( collect_pod inc );
299   @valid_props{@valid_props} = delete( @props{@valid_props} );
300   warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
301
302   my %data = (
303     module       => $module,
304     filename     => $filename,
305     version      => undef,
306     packages     => [],
307     versions     => {},
308     pod          => {},
309     pod_headings => [],
310     collect_pod  => 0,
311
312     %valid_props,
313   );
314
315   my $self = bless(\%data, $class);
316
317   if ( $handle ) {
318     $self->_parse_fh($handle);
319   }
320   else {
321     $self->_parse_file();
322   }
323
324   unless($self->{module} and length($self->{module})) {
325     my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
326     if($f =~ /\.pm$/) {
327       $f =~ s/\..+$//;
328       my @candidates = grep /$f$/, @{$self->{packages}};
329       $self->{module} = shift(@candidates); # punt
330     }
331     else {
332       if(grep /main/, @{$self->{packages}}) {
333         $self->{module} = 'main';
334       }
335       else {
336         $self->{module} = $self->{packages}[0] || '';
337       }
338     }
339   }
340
341   $self->{version} = $self->{versions}{$self->{module}}
342       if defined( $self->{module} );
343
344   return $self;
345 }
346
347 # class method
348 sub _do_find_module {
349   my $class   = shift;
350   my $module  = shift || die 'find_module_by_name() requires a package name';
351   my $dirs    = shift || \@INC;
352
353   my $file = File::Spec->catfile(split( /::/, $module));
354   foreach my $dir ( @$dirs ) {
355     my $testfile = File::Spec->catfile($dir, $file);
356     return [ File::Spec->rel2abs( $testfile ), $dir ]
357         if -e $testfile and !-d _;  # For stuff like ExtUtils::xsubpp
358     return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
359         if -e "$testfile.pm";
360   }
361   return;
362 }
363
364 # class method
365 sub find_module_by_name {
366   my $found = shift()->_do_find_module(@_) or return;
367   return $found->[0];
368 }
369
370 # class method
371 sub find_module_dir_by_name {
372   my $found = shift()->_do_find_module(@_) or return;
373   return $found->[1];
374 }
375
376
377 # given a line of perl code, attempt to parse it if it looks like a
378 # $VERSION assignment, returning sigil, full name, & package name
379 sub _parse_version_expression {
380   my $self = shift;
381   my $line = shift;
382
383   my( $sig, $var, $pkg );
384   if ( $line =~ $VERS_REGEXP ) {
385     ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
386     if ( $pkg ) {
387       $pkg = ($pkg eq '::') ? 'main' : $pkg;
388       $pkg =~ s/::$//;
389     }
390   }
391
392   return ( $sig, $var, $pkg );
393 }
394
395 sub _parse_file {
396   my $self = shift;
397
398   my $filename = $self->{filename};
399   my $fh = IO::File->new( $filename )
400     or die( "Can't open '$filename': $!" );
401
402   $self->_parse_fh($fh);
403 }
404
405 sub _parse_fh {
406   my ($self, $fh) = @_;
407
408   my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
409   my( @pkgs, %vers, %pod, @pod );
410   my $pkg = 'main';
411   my $pod_sect = '';
412   my $pod_data = '';
413
414   while (defined( my $line = <$fh> )) {
415     my $line_num = $.;
416
417     chomp( $line );
418     next if $line =~ /^\s*#/;
419
420     $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
421
422     # Would be nice if we could also check $in_string or something too
423     last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
424
425     if ( $in_pod || $line =~ /^=cut/ ) {
426
427       if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
428         push( @pod, $1 );
429         if ( $self->{collect_pod} && length( $pod_data ) ) {
430           $pod{$pod_sect} = $pod_data;
431           $pod_data = '';
432         }
433         $pod_sect = $1;
434
435
436       } elsif ( $self->{collect_pod} ) {
437         $pod_data .= "$line\n";
438
439       }
440
441     } else {
442
443       $pod_sect = '';
444       $pod_data = '';
445
446       # parse $line to see if it's a $VERSION declaration
447       my( $vers_sig, $vers_fullname, $vers_pkg ) =
448           $self->_parse_version_expression( $line );
449
450       if ( $line =~ $PKG_REGEXP ) {
451         $pkg = $1;
452         push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
453         $vers{$pkg} = (defined $2 ? $2 : undef)  unless exists( $vers{$pkg} );
454         $need_vers = defined $2 ? 0 : 1;
455
456       # VERSION defined with full package spec, i.e. $Module::VERSION
457       } elsif ( $vers_fullname && $vers_pkg ) {
458         push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
459         $need_vers = 0 if $vers_pkg eq $pkg;
460
461         unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
462           $vers{$vers_pkg} =
463             $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
464         } else {
465           # Warn unless the user is using the "$VERSION = eval
466           # $VERSION" idiom (though there are probably other idioms
467           # that we should watch out for...)
468           warn <<"EOM" unless $line =~ /=\s*eval/;
469 Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
470 ignoring subsequent declaration on line $line_num.
471 EOM
472         }
473
474       # first non-comment line in undeclared package main is VERSION
475       } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
476         $need_vers = 0;
477         my $v =
478           $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
479         $vers{$pkg} = $v;
480         push( @pkgs, 'main' );
481
482       # first non-comment line in undeclared package defines package main
483       } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
484         $need_vers = 1;
485         $vers{main} = '';
486         push( @pkgs, 'main' );
487
488       # only keep if this is the first $VERSION seen
489       } elsif ( $vers_fullname && $need_vers ) {
490         $need_vers = 0;
491         my $v =
492           $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
493
494
495         unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
496           $vers{$pkg} = $v;
497         } else {
498           warn <<"EOM";
499 Package '$pkg' already declared with version '$vers{$pkg}'
500 ignoring new version '$v' on line $line_num.
501 EOM
502         }
503
504       }
505
506     }
507
508   }
509
510   if ( $self->{collect_pod} && length($pod_data) ) {
511     $pod{$pod_sect} = $pod_data;
512   }
513
514   $self->{versions} = \%vers;
515   $self->{packages} = \@pkgs;
516   $self->{pod} = \%pod;
517   $self->{pod_headings} = \@pod;
518 }
519
520 {
521 my $pn = 0;
522 sub _evaluate_version_line {
523   my $self = shift;
524   my( $sigil, $var, $line ) = @_;
525
526   # Some of this code came from the ExtUtils:: hierarchy.
527
528   # We compile into $vsub because 'use version' would cause
529   # compiletime/runtime issues with local()
530   my $vsub;
531   $pn++; # everybody gets their own package
532   my $eval = qq{BEGIN { q#  Hide from _packages_inside()
533     #; package Module::Metadata::_version::p$pn;
534     use version;
535     no strict;
536
537       \$vsub = sub {
538         local $sigil$var;
539         \$$var=undef;
540         $line;
541         \$$var
542       };
543   }};
544
545   local $^W;
546   # Try to get the $VERSION
547   eval $eval;
548   # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
549   # installed, so we need to hunt in ./lib for it
550   if ( $@ =~ /Can't locate/ && -d 'lib' ) {
551     local @INC = ('lib',@INC);
552     eval $eval;
553   }
554   warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
555     if $@;
556   (ref($vsub) eq 'CODE') or
557     die "failed to build version sub for $self->{filename}";
558   my $result = eval { $vsub->() };
559   die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
560     if $@;
561
562   # Upgrade it into a version object
563   my $version = eval { _dwim_version($result) };
564
565   die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
566     unless defined $version; # "0" is OK!
567
568   return $version;
569 }
570 }
571
572 # Try to DWIM when things fail the lax version test in obvious ways
573 {
574   my @version_prep = (
575     # Best case, it just works
576     sub { return shift },
577
578     # If we still don't have a version, try stripping any
579     # trailing junk that is prohibited by lax rules
580     sub {
581       my $v = shift;
582       $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
583       return $v;
584     },
585
586     # Activestate apparently creates custom versions like '1.23_45_01', which
587     # cause version.pm to think it's an invalid alpha.  So check for that
588     # and strip them
589     sub {
590       my $v = shift;
591       my $num_dots = () = $v =~ m{(\.)}g;
592       my $num_unders = () = $v =~ m{(_)}g;
593       my $leading_v = substr($v,0,1) eq 'v';
594       if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
595         $v =~ s{_}{}g;
596         $num_unders = () = $v =~ m{(_)}g;
597       }
598       return $v;
599     },
600
601     # Worst case, try numifying it like we would have before version objects
602     sub {
603       my $v = shift;
604       no warnings 'numeric';
605       return 0 + $v;
606     },
607
608   );
609
610   sub _dwim_version {
611     my ($result) = shift;
612
613     return $result if ref($result) eq 'version';
614
615     my ($version, $error);
616     for my $f (@version_prep) {
617       $result = $f->($result);
618       $version = eval { version->new($result) };
619       $error ||= $@ if $@; # capture first failure
620       last if defined $version;
621     }
622
623     die $error unless defined $version;
624
625     return $version;
626   }
627 }
628
629 ############################################################
630
631 # accessors
632 sub name            { $_[0]->{module}           }
633
634 sub filename        { $_[0]->{filename}         }
635 sub packages_inside { @{$_[0]->{packages}}      }
636 sub pod_inside      { @{$_[0]->{pod_headings}}  }
637 sub contains_pod    { $#{$_[0]->{pod_headings}} }
638
639 sub version {
640     my $self = shift;
641     my $mod  = shift || $self->{module};
642     my $vers;
643     if ( defined( $mod ) && length( $mod ) &&
644          exists( $self->{versions}{$mod} ) ) {
645         return $self->{versions}{$mod};
646     } else {
647         return undef;
648     }
649 }
650
651 sub pod {
652     my $self = shift;
653     my $sect = shift;
654     if ( defined( $sect ) && length( $sect ) &&
655          exists( $self->{pod}{$sect} ) ) {
656         return $self->{pod}{$sect};
657     } else {
658         return undef;
659     }
660 }
661
662 1;
663
664 =head1 NAME
665
666 Module::Metadata - Gather package and POD information from perl module files
667
668 =head1 DESCRIPTION
669
670 =over 4
671
672 =item new_from_file($filename, collect_pod => 1)
673
674 Construct a C<Module::Metadata> object given the path to a file. Takes an optional
675 argument C<collect_pod> which is a boolean that determines whether
676 POD data is collected and stored for reference. POD data is not
677 collected by default. POD headings are always collected.
678
679 =item new_from_handle($handle, $filename, collect_pod => 1)
680
681 This works just like C<new_from_file>, except that a handle can be provided
682 as the first argument.  Note that there is no validation to confirm that the
683 handle is a handle or something that can act like one.  Passing something that
684 isn't a handle will cause a exception when trying to read from it.  The
685 C<filename> argument is mandatory or undef will be returned.
686
687 =item new_from_module($module, collect_pod => 1, inc => \@dirs)
688
689 Construct a C<Module::Metadata> object given a module or package name. In addition
690 to accepting the C<collect_pod> argument as described above, this
691 method accepts a C<inc> argument which is a reference to an array of
692 of directories to search for the module. If none are given, the
693 default is @INC.
694
695
696 =item name()
697
698 Returns the name of the package represented by this module. If there
699 are more than one packages, it makes a best guess based on the
700 filename. If it's a script (i.e. not a *.pm) the package name is
701 'main'.
702
703 =item version($package)
704
705 Returns the version as defined by the $VERSION variable for the
706 package as returned by the C<name> method if no arguments are
707 given. If given the name of a package it will attempt to return the
708 version of that package if it is specified in the file.
709
710 =item filename()
711
712 Returns the absolute path to the file.
713
714 =item packages_inside()
715
716 Returns a list of packages.
717
718 =item pod_inside()
719
720 Returns a list of POD sections.
721
722 =item contains_pod()
723
724 Returns true if there is any POD in the file.
725
726 =item pod($section)
727
728 Returns the POD data in the given section.
729
730 =item find_module_by_name($module, \@dirs)
731
732 Returns the path to a module given the module or package name. A list
733 of directories can be passed in as an optional parameter, otherwise
734 @INC is searched.
735
736 Can be called as either an object or a class method.
737
738 =item find_module_dir_by_name($module, \@dirs)
739
740 Returns the entry in C<@dirs> (or C<@INC> by default) that contains
741 the module C<$module>. A list of directories can be passed in as an
742 optional parameter, otherwise @INC is searched.
743
744 Can be called as either an object or a class method.
745
746 =item package_versions_from_directory($dir, \@files?)
747
748 Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
749 for those files in C<$dir> - and reads each file for packages and versions,
750 returning a hashref of the form:
751
752   {
753     'Package::Name' => {
754       version => '0.123',
755       file => 'Package/Name.pm'
756     },
757     'OtherPackage::Name' => ...
758   }
759
760 =item log_info (internal)
761
762 Used internally to perform logging; imported from Log::Contextual if
763 Log::Contextual has already been loaded, otherwise simply calls warn.
764
765 =back
766
767 =head1 AUTHOR
768
769 Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
770
771 Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
772 assistance from David Golden (xdg) <dagolden@cpan.org>
773
774 =head1 COPYRIGHT
775
776 Copyright (c) 2001-2011 Ken Williams.  All rights reserved.
777
778 This library is free software; you can redistribute it and/or
779 modify it under the same terms as Perl itself.
780
781 =cut
782