1# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
2# vim:ts=8:sw=2:et:sta:sts=2:tw=78
3package Module::Metadata; # git description: v1.000037-8-g92dec6c
4# ABSTRACT: Gather package and POD information from perl module files
5
6# Adapted from Perl-licensed code originally distributed with
7# Module-Build by Ken Williams
8
9# This module provides routines to gather information about
10# perl modules (assuming this may be expanded in the distant
11# parrot future to look at other types of modules).
12
13sub __clean_eval { eval $_[0] }
14use strict;
15use warnings;
16
17our $VERSION = '1.000038';
18
19use Carp qw/croak/;
20use File::Spec;
21BEGIN {
22       # Try really hard to not depend ony any DynaLoaded module, such as IO::File or Fcntl
23       eval {
24               require Fcntl; Fcntl->import('SEEK_SET'); 1;
25       } or *SEEK_SET = sub { 0 }
26}
27use version 0.87;
28BEGIN {
29  if ($INC{'Log/Contextual.pm'}) {
30    require "Log/Contextual/WarnLogger.pm"; # Hide from AutoPrereqs
31    Log::Contextual->import('log_info',
32      '-default_logger' => Log::Contextual::WarnLogger->new({ env_prefix => 'MODULE_METADATA', }),
33    );
34  }
35  else {
36    *log_info = sub (&) { warn $_[0]->() };
37  }
38}
39use File::Find qw(find);
40
41my $V_NUM_REGEXP = qr{v?[0-9._]+};  # crudely, a v-string or decimal
42
43my $PKG_FIRST_WORD_REGEXP = qr{ # the FIRST word in a package name
44  [a-zA-Z_]                     # the first word CANNOT start with a digit
45    (?:
46      [\w']?                    # can contain letters, digits, _, or ticks
47      \w                        # But, NO multi-ticks or trailing ticks
48    )*
49}x;
50
51my $PKG_ADDL_WORD_REGEXP = qr{ # the 2nd+ word in a package name
52  \w                           # the 2nd+ word CAN start with digits
53    (?:
54      [\w']?                   # and can contain letters or ticks
55      \w                       # But, NO multi-ticks or trailing ticks
56    )*
57}x;
58
59my $PKG_NAME_REGEXP = qr{ # match a package name
60  (?: :: )?               # a pkg name can start with arisdottle
61  $PKG_FIRST_WORD_REGEXP  # a package word
62  (?:
63    (?: :: )+             ### arisdottle (allow one or many times)
64    $PKG_ADDL_WORD_REGEXP ### a package word
65  )*                      # ^ zero, one or many times
66  (?:
67    ::                    # allow trailing arisdottle
68  )?
69}x;
70
71my $PKG_REGEXP  = qr{   # match a package declaration
72  ^[\s\{;]*             # intro chars on a line
73  package               # the word 'package'
74  \s+                   # whitespace
75  ($PKG_NAME_REGEXP)    # a package name
76  \s*                   # optional whitespace
77  ($V_NUM_REGEXP)?      # optional version number
78  \s*                   # optional whitespace
79  [;\{]                 # semicolon line terminator or block start (since 5.16)
80}x;
81
82my $CLASS_REGEXP = qr{  # match a class declaration (core since 5.38)
83  ^[\s\{;]*             # intro chars on a line
84  class                 # the word 'class'
85  \s+                   # whitespace
86  ($PKG_NAME_REGEXP)    # a package name
87  \s*                   # optional whitespace
88  ($V_NUM_REGEXP)?      # optional version number
89  \s*                   # optional whitespace
90  [;\{]                 # semicolon line terminator or block start
91}x;
92
93my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
94  ([\$*])         # sigil - $ or *
95  (
96    (             # optional leading package name
97      (?:::|\')?  # possibly starting like just :: (a la $::VERSION)
98      (?:\w+(?:::|\'))*  # Foo::Bar:: ...
99    )?
100    VERSION
101  )\b
102}x;
103
104my $VERS_REGEXP = qr{ # match a VERSION definition
105  (?:
106    \(\s*$VARNAME_REGEXP\s*\) # with parens
107  |
108    $VARNAME_REGEXP           # without parens
109  )
110  \s*
111  =[^=~>]  # = but not ==, nor =~, nor =>
112}x;
113
114sub new_from_file {
115  my $class    = shift;
116  my $filename = File::Spec->rel2abs( shift );
117
118  return undef unless defined( $filename ) && -f $filename;
119  return $class->_init(undef, $filename, @_);
120}
121
122sub new_from_handle {
123  my $class    = shift;
124  my $handle   = shift;
125  my $filename = shift;
126  return undef unless defined($handle) && defined($filename);
127  $filename = File::Spec->rel2abs( $filename );
128
129  return $class->_init(undef, $filename, @_, handle => $handle);
130
131}
132
133
134sub new_from_module {
135  my $class   = shift;
136  my $module  = shift;
137  my %props   = @_;
138
139  $props{inc} ||= \@INC;
140  my $filename = $class->find_module_by_name( $module, $props{inc} );
141  return undef unless defined( $filename ) && -f $filename;
142  return $class->_init($module, $filename, %props);
143}
144
145{
146
147  my $compare_versions = sub {
148    my ($v1, $op, $v2) = @_;
149    $v1 = version->new($v1)
150      unless UNIVERSAL::isa($v1,'version');
151
152    my $eval_str = "\$v1 $op \$v2";
153    my $result   = eval $eval_str;
154    log_info { "error comparing versions: '$eval_str' $@" } if $@;
155
156    return $result;
157  };
158
159  my $normalize_version = sub {
160    my ($version) = @_;
161    if ( $version =~ /[=<>!,]/ ) { # logic, not just version
162      # take as is without modification
163    }
164    elsif ( ref $version eq 'version' ) { # version objects
165      $version = $version->is_qv ? $version->normal : $version->stringify;
166    }
167    elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
168      # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
169      $version = "v$version";
170    }
171    else {
172      # leave alone
173    }
174    return $version;
175  };
176
177  # separate out some of the conflict resolution logic
178
179  my $resolve_module_versions = sub {
180    my $packages = shift;
181
182    my( $file, $version );
183    my $err = '';
184      foreach my $p ( @$packages ) {
185        if ( defined( $p->{version} ) ) {
186          if ( defined( $version ) ) {
187            if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
188              $err .= "  $p->{file} ($p->{version})\n";
189            }
190            else {
191              # same version declared multiple times, ignore
192            }
193          }
194          else {
195            $file    = $p->{file};
196            $version = $p->{version};
197          }
198        }
199      $file ||= $p->{file} if defined( $p->{file} );
200    }
201
202    if ( $err ) {
203      $err = "  $file ($version)\n" . $err;
204    }
205
206    my %result = (
207      file    => $file,
208      version => $version,
209      err     => $err
210    );
211
212    return \%result;
213  };
214
215  sub provides {
216    my $class = shift;
217
218    croak "provides() requires key/value pairs \n" if @_ % 2;
219    my %args = @_;
220
221    croak "provides() takes only one of 'dir' or 'files'\n"
222      if $args{dir} && $args{files};
223
224    croak "provides() requires a 'version' argument"
225      unless defined $args{version};
226
227    croak "provides() does not support version '$args{version}' metadata"
228        unless grep $args{version} eq $_, qw/1.4 2/;
229
230    $args{prefix} = 'lib' unless defined $args{prefix};
231
232    my $p;
233    if ( $args{dir} ) {
234      $p = $class->package_versions_from_directory($args{dir});
235    }
236    else {
237      croak "provides() requires 'files' to be an array reference\n"
238        unless ref $args{files} eq 'ARRAY';
239      $p = $class->package_versions_from_directory($args{files});
240    }
241
242    # Now, fix up files with prefix
243    if ( length $args{prefix} ) { # check in case disabled with q{}
244      $args{prefix} =~ s{/$}{};
245      for my $v ( values %$p ) {
246        $v->{file} = "$args{prefix}/$v->{file}";
247      }
248    }
249
250    return $p
251  }
252
253  sub package_versions_from_directory {
254    my ( $class, $dir, $files ) = @_;
255
256    my @files;
257
258    if ( $files ) {
259      @files = @$files;
260    }
261    else {
262      find( {
263        wanted => sub {
264          push @files, $_ if -f $_ && /\.pm$/;
265        },
266        no_chdir => 1,
267      }, $dir );
268    }
269
270    # First, we enumerate all packages & versions,
271    # separating into primary & alternative candidates
272    my( %prime, %alt );
273    foreach my $file (@files) {
274      my $mapped_filename = File::Spec->abs2rel( $file, $dir );
275      my @path = File::Spec->splitdir( $mapped_filename );
276      (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
277
278      my $pm_info = $class->new_from_file( $file );
279
280      foreach my $package ( $pm_info->packages_inside ) {
281        next if $package eq 'main';  # main can appear numerous times, ignore
282        next if $package eq 'DB';    # special debugging package, ignore
283        next if grep /^_/, split( /::/, $package ); # private package, ignore
284
285        my $version = $pm_info->version( $package );
286
287        $prime_package = $package if lc($prime_package) eq lc($package);
288        if ( $package eq $prime_package ) {
289          if ( exists( $prime{$package} ) ) {
290            croak "Unexpected conflict in '$package'; multiple versions found.\n";
291          }
292          else {
293            $mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename);
294            $prime{$package}{file} = $mapped_filename;
295            $prime{$package}{version} = $version if defined( $version );
296          }
297        }
298        else {
299          push( @{$alt{$package}}, {
300                                    file    => $mapped_filename,
301                                    version => $version,
302                                   } );
303        }
304      }
305    }
306
307    # Then we iterate over all the packages found above, identifying conflicts
308    # and selecting the "best" candidate for recording the file & version
309    # for each package.
310    foreach my $package ( keys( %alt ) ) {
311      my $result = $resolve_module_versions->( $alt{$package} );
312
313      if ( exists( $prime{$package} ) ) { # primary package selected
314
315        if ( $result->{err} ) {
316        # Use the selected primary package, but there are conflicting
317        # errors among multiple alternative packages that need to be
318        # reported
319          log_info {
320            "Found conflicting versions for package '$package'\n" .
321            "  $prime{$package}{file} ($prime{$package}{version})\n" .
322            $result->{err}
323          };
324
325        }
326        elsif ( defined( $result->{version} ) ) {
327        # There is a primary package selected, and exactly one
328        # alternative package
329
330        if ( exists( $prime{$package}{version} ) &&
331             defined( $prime{$package}{version} ) ) {
332          # Unless the version of the primary package agrees with the
333          # version of the alternative package, report a conflict
334        if ( $compare_versions->(
335                 $prime{$package}{version}, '!=', $result->{version}
336               )
337             ) {
338
339            log_info {
340              "Found conflicting versions for package '$package'\n" .
341              "  $prime{$package}{file} ($prime{$package}{version})\n" .
342              "  $result->{file} ($result->{version})\n"
343            };
344          }
345
346        }
347        else {
348          # The prime package selected has no version so, we choose to
349          # use any alternative package that does have a version
350          $prime{$package}{file}    = $result->{file};
351          $prime{$package}{version} = $result->{version};
352        }
353
354        }
355        else {
356        # no alt package found with a version, but we have a prime
357        # package so we use it whether it has a version or not
358        }
359
360      }
361      else { # No primary package was selected, use the best alternative
362
363        if ( $result->{err} ) {
364          log_info {
365            "Found conflicting versions for package '$package'\n" .
366            $result->{err}
367          };
368        }
369
370        # Despite possible conflicting versions, we choose to record
371        # something rather than nothing
372        $prime{$package}{file}    = $result->{file};
373        $prime{$package}{version} = $result->{version}
374          if defined( $result->{version} );
375      }
376    }
377
378    # Normalize versions.  Can't use exists() here because of bug in YAML::Node.
379    # XXX "bug in YAML::Node" comment seems irrelevant -- dagolden, 2009-05-18
380    for (grep defined $_->{version}, values %prime) {
381      $_->{version} = $normalize_version->( $_->{version} );
382    }
383
384    return \%prime;
385  }
386}
387
388
389sub _init {
390  my $class    = shift;
391  my $module   = shift;
392  my $filename = shift;
393  my %props = @_;
394
395  my $handle = delete $props{handle};
396  my( %valid_props, @valid_props );
397  @valid_props = qw( collect_pod inc decode_pod );
398  @valid_props{@valid_props} = delete( @props{@valid_props} );
399  warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
400
401  my %data = (
402    module       => $module,
403    filename     => $filename,
404    version      => undef,
405    packages     => [],
406    versions     => {},
407    pod          => {},
408    pod_headings => [],
409    collect_pod  => 0,
410
411    %valid_props,
412  );
413
414  my $self = bless(\%data, $class);
415
416  if ( not $handle ) {
417    my $filename = $self->{filename};
418    open $handle, '<', $filename
419      or croak( "Can't open '$filename': $!" );
420
421    $self->_handle_bom($handle, $filename);
422  }
423  $self->_parse_fh($handle);
424
425  @{$self->{packages}} = __uniq(@{$self->{packages}});
426
427  unless($self->{module} and length($self->{module})) {
428    # CAVEAT (possible TODO): .pmc files not treated the same as .pm
429    if ($self->{filename} =~ /\.pm$/) {
430      my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
431      $f =~ s/\..+$//;
432      my @candidates = grep /(^|::)$f$/, @{$self->{packages}};
433      $self->{module} = shift(@candidates); # this may be undef
434    }
435    else {
436      # this seems like an atrocious heuristic, albeit marginally better than
437      # what was here before. It should be rewritten entirely to be more like
438      # "if it's not a .pm file, it's not require()able as a name, therefore
439      # name() should be undef."
440      if ((grep /main/, @{$self->{packages}})
441          or (grep /main/, keys %{$self->{versions}})) {
442        $self->{module} = 'main';
443      }
444      else {
445        # TODO: this should maybe default to undef instead
446        $self->{module} = $self->{packages}[0] || '';
447      }
448    }
449  }
450
451  $self->{version} = $self->{versions}{$self->{module}}
452    if defined( $self->{module} );
453
454  return $self;
455}
456
457# class method
458sub _do_find_module {
459  my $class   = shift;
460  my $module  = shift || croak 'find_module_by_name() requires a package name';
461  my $dirs    = shift || \@INC;
462
463  my $file = File::Spec->catfile(split( /::/, $module));
464  foreach my $dir ( @$dirs ) {
465    my $testfile = File::Spec->catfile($dir, $file);
466    return [ File::Spec->rel2abs( $testfile ), $dir ]
467      if -e $testfile and !-d _;  # For stuff like ExtUtils::xsubpp
468    # CAVEAT (possible TODO): .pmc files are not discoverable here
469    $testfile .= '.pm';
470    return [ File::Spec->rel2abs( $testfile ), $dir ]
471      if -e $testfile;
472  }
473  return;
474}
475
476# class method
477sub find_module_by_name {
478  my $found = shift()->_do_find_module(@_) or return;
479  return $found->[0];
480}
481
482# class method
483sub find_module_dir_by_name {
484  my $found = shift()->_do_find_module(@_) or return;
485  return $found->[1];
486}
487
488
489# given a line of perl code, attempt to parse it if it looks like a
490# $VERSION assignment, returning sigil, full name, & package name
491sub _parse_version_expression {
492  my $self = shift;
493  my $line = shift;
494
495  my( $sigil, $variable_name, $package);
496  if ( $line =~ /$VERS_REGEXP/o ) {
497    ( $sigil, $variable_name, $package) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
498    if ( $package ) {
499      $package = ($package eq '::') ? 'main' : $package;
500      $package =~ s/::$//;
501    }
502  }
503
504  return ( $sigil, $variable_name, $package );
505}
506
507# Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream.
508# If there's one, then skip it and set the :encoding layer appropriately.
509sub _handle_bom {
510  my ($self, $fh, $filename) = @_;
511
512  my $pos = tell $fh;
513  return unless defined $pos;
514
515  my $buf = ' ' x 2;
516  my $count = read $fh, $buf, length $buf;
517  return unless defined $count and $count >= 2;
518
519  my $encoding;
520  if ( $buf eq "\x{FE}\x{FF}" ) {
521    $encoding = 'UTF-16BE';
522  }
523  elsif ( $buf eq "\x{FF}\x{FE}" ) {
524    $encoding = 'UTF-16LE';
525  }
526  elsif ( $buf eq "\x{EF}\x{BB}" ) {
527    $buf = ' ';
528    $count = read $fh, $buf, length $buf;
529    if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) {
530      $encoding = 'UTF-8';
531    }
532  }
533
534  if ( defined $encoding ) {
535    if ( "$]" >= 5.008 ) {
536      binmode( $fh, ":encoding($encoding)" );
537    }
538  }
539  else {
540    seek $fh, $pos, SEEK_SET
541      or croak( sprintf "Can't reset position to the top of '$filename'" );
542  }
543
544  return $encoding;
545}
546
547sub _parse_fh {
548  my ($self, $fh) = @_;
549
550  my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
551  my( @packages, %vers, %pod, @pod );
552  my $package = 'main';
553  my $pod_sect = '';
554  my $pod_data = '';
555  my $in_end = 0;
556  my $encoding = '';
557
558  while (defined( my $line = <$fh> )) {
559    my $line_num = $.;
560
561    chomp( $line );
562
563    # From toke.c : any line that begins by "=X", where X is an alphabetic
564    # character, introduces a POD segment.
565    my $is_cut;
566    if ( $line =~ /^=([a-zA-Z].*)/ ) {
567      my $cmd = $1;
568      # Then it goes back to Perl code for "=cutX" where X is a non-alphabetic
569      # character (which includes the newline, but here we chomped it away).
570      $is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/;
571      $in_pod = !$is_cut;
572    }
573
574    if ( $in_pod ) {
575
576      if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) {
577        push( @pod, $1 );
578        if ( $self->{collect_pod} && length( $pod_data ) ) {
579          $pod{$pod_sect} = $pod_data;
580          $pod_data = '';
581        }
582        $pod_sect = $1;
583      }
584      elsif ( $self->{collect_pod} ) {
585        if ( $self->{decode_pod} && $line =~ /^=encoding ([\w-]+)/ ) {
586          $encoding = $1;
587        }
588        $pod_data .= "$line\n";
589      }
590      next;
591    }
592    elsif ( $is_cut ) {
593      if ( $self->{collect_pod} && length( $pod_data ) ) {
594        $pod{$pod_sect} = $pod_data;
595        $pod_data = '';
596      }
597      $pod_sect = '';
598      next;
599    }
600
601    # Skip after __END__
602    next if $in_end;
603
604    # Skip comments in code
605    next if $line =~ /^\s*#/;
606
607    # Would be nice if we could also check $in_string or something too
608    if ($line eq '__END__') {
609      $in_end++;
610      next;
611    }
612
613    last if $line eq '__DATA__';
614
615    # parse $line to see if it's a $VERSION declaration
616    my( $version_sigil, $version_fullname, $version_package ) =
617      index($line, 'VERSION') >= 1
618        ? $self->_parse_version_expression( $line )
619        : ();
620
621    if ( $line =~ /$PKG_REGEXP/o or $line =~ /$CLASS_REGEXP/ ) {
622      $package = $1;
623      my $version = $2;
624      push( @packages, $package ) unless grep( $package eq $_, @packages );
625      $need_vers = defined $version ? 0 : 1;
626
627      if ( not exists $vers{$package} and defined $version ){
628        # Upgrade to a version object.
629        my $dwim_version = eval { _dwim_version($version) };
630        croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n"
631          unless defined $dwim_version;  # "0" is OK!
632        $vers{$package} = $dwim_version;
633      }
634    }
635
636    # VERSION defined with full package spec, i.e. $Module::VERSION
637    elsif ( $version_fullname && $version_package ) {
638      # we do NOT save this package in found @packages
639      $need_vers = 0 if $version_package eq $package;
640
641      unless ( defined $vers{$version_package} && length $vers{$version_package} ) {
642        $vers{$version_package} = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
643      }
644    }
645
646    # first non-comment line in undeclared package main is VERSION
647    elsif ( $package eq 'main' && $version_fullname && !exists($vers{main}) ) {
648      $need_vers = 0;
649      my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
650      $vers{$package} = $v;
651      push( @packages, 'main' );
652    }
653
654    # first non-comment line in undeclared package defines package main
655    elsif ( $package eq 'main' && !exists($vers{main}) && $line =~ /\w/ ) {
656      $need_vers = 1;
657      $vers{main} = '';
658      push( @packages, 'main' );
659    }
660
661    # only keep if this is the first $VERSION seen
662    elsif ( $version_fullname && $need_vers ) {
663      $need_vers = 0;
664      my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
665
666      unless ( defined $vers{$package} && length $vers{$package} ) {
667        $vers{$package} = $v;
668      }
669    }
670  } # end loop over each line
671
672  if ( $self->{collect_pod} && length($pod_data) ) {
673    $pod{$pod_sect} = $pod_data;
674  }
675
676  if ( $self->{decode_pod} && $encoding ) {
677    require Encode;
678    $_ = Encode::decode( $encoding, $_ ) for values %pod;
679  }
680
681  $self->{versions} = \%vers;
682  $self->{packages} = \@packages;
683  $self->{pod} = \%pod;
684  $self->{pod_headings} = \@pod;
685}
686
687sub __uniq (@)
688{
689    my (%seen, $key);
690    grep !$seen{ $key = $_ }++, @_;
691}
692
693{
694my $pn = 0;
695sub _evaluate_version_line {
696  my $self = shift;
697  my( $sigil, $variable_name, $line ) = @_;
698
699  # We compile into a local sub because 'use version' would cause
700  # compiletime/runtime issues with local()
701  $pn++; # everybody gets their own package
702  my $eval = qq{ my \$dummy = q#  Hide from _packages_inside()
703    #; package Module::Metadata::_version::p${pn};
704    use version;
705    sub {
706      local $sigil$variable_name;
707      $line;
708      return \$$variable_name if defined \$$variable_name;
709      return \$Module::Metadata::_version::p${pn}::$variable_name;
710    };
711  };
712
713  $eval = $1 if $eval =~ m{^(.+)}s;
714
715  local $^W;
716  # Try to get the $VERSION
717  my $vsub = __clean_eval($eval);
718  # some modules say $VERSION <equal sign> $Foo::Bar::VERSION, but Foo::Bar isn't
719  # installed, so we need to hunt in ./lib for it
720  if ( $@ =~ /Can't locate/ && -d 'lib' ) {
721    local @INC = ('lib',@INC);
722    $vsub = __clean_eval($eval);
723  }
724  warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
725    if $@;
726
727  (ref($vsub) eq 'CODE') or
728    croak "failed to build version sub for $self->{filename}";
729
730  my $result = eval { $vsub->() };
731  # FIXME: $eval is not the right thing to print here
732  croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
733    if $@;
734
735  # Upgrade it into a version object
736  my $version = eval { _dwim_version($result) };
737
738  # FIXME: $eval is not the right thing to print here
739  croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
740    unless defined $version; # "0" is OK!
741
742  return $version;
743}
744}
745
746# Try to DWIM when things fail the lax version test in obvious ways
747{
748  my @version_prep = (
749    # Best case, it just works
750    sub { return shift },
751
752    # If we still don't have a version, try stripping any
753    # trailing junk that is prohibited by lax rules
754    sub {
755      my $v = shift;
756      $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
757      return $v;
758    },
759
760    # Activestate apparently creates custom versions like '1.23_45_01', which
761    # cause version.pm to think it's an invalid alpha.  So check for that
762    # and strip them
763    sub {
764      my $v = shift;
765      my $num_dots = () = $v =~ m{(\.)}g;
766      my $num_unders = () = $v =~ m{(_)}g;
767      my $leading_v = substr($v,0,1) eq 'v';
768      if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
769        $v =~ s{_}{}g;
770        $num_unders = () = $v =~ m{(_)}g;
771      }
772      return $v;
773    },
774
775    # Worst case, try numifying it like we would have before version objects
776    sub {
777      my $v = shift;
778      no warnings 'numeric';
779      return 0 + $v;
780    },
781
782  );
783
784  sub _dwim_version {
785    my ($result) = shift;
786
787    return $result if ref($result) eq 'version';
788
789    my ($version, $error);
790    for my $f (@version_prep) {
791      $result = $f->($result);
792      $version = eval { version->new($result) };
793      $error ||= $@ if $@; # capture first failure
794      last if defined $version;
795    }
796
797    croak $error unless defined $version;
798
799    return $version;
800  }
801}
802
803############################################################
804
805# accessors
806sub name            { $_[0]->{module}            }
807
808sub filename        { $_[0]->{filename}          }
809sub packages_inside { @{$_[0]->{packages}}       }
810sub pod_inside      { @{$_[0]->{pod_headings}}   }
811sub contains_pod    { 0+@{$_[0]->{pod_headings}} }
812
813sub version {
814    my $self = shift;
815    my $mod  = shift || $self->{module};
816    my $vers;
817    if ( defined( $mod ) && length( $mod ) &&
818         exists( $self->{versions}{$mod} ) ) {
819        return $self->{versions}{$mod};
820    }
821    else {
822        return undef;
823    }
824}
825
826sub pod {
827    my $self = shift;
828    my $sect = shift;
829    if ( defined( $sect ) && length( $sect ) &&
830         exists( $self->{pod}{$sect} ) ) {
831        return $self->{pod}{$sect};
832    }
833    else {
834        return undef;
835    }
836}
837
838sub is_indexable {
839  my ($self, $package) = @_;
840
841  my @indexable_packages = grep $_ ne 'main', $self->packages_inside;
842
843  # check for specific package, if provided
844  return !! grep $_ eq $package, @indexable_packages if $package;
845
846  # otherwise, check for any indexable packages at all
847  return !! @indexable_packages;
848}
849
8501;
851
852__END__
853
854=pod
855
856=encoding UTF-8
857
858=head1 NAME
859
860Module::Metadata - Gather package and POD information from perl module files
861
862=head1 VERSION
863
864version 1.000038
865
866=head1 SYNOPSIS
867
868  use Module::Metadata;
869
870  # information about a .pm file
871  my $info = Module::Metadata->new_from_file( $file );
872  my $version = $info->version;
873
874  # CPAN META 'provides' field for .pm files in a directory
875  my $provides = Module::Metadata->provides(
876    dir => 'lib', version => 2
877  );
878
879=head1 DESCRIPTION
880
881This module provides a standard way to gather metadata about a .pm file through
882(mostly) static analysis and (some) code execution.  When determining the
883version of a module, the C<$VERSION> assignment is C<eval>ed, as is traditional
884in the CPAN toolchain.
885
886=head1 CLASS METHODS
887
888=head2 C<< new_from_file($filename, collect_pod => 1, decode_pod => 1) >>
889
890Constructs a C<Module::Metadata> object given the path to a file.  Returns
891undef if the filename does not exist.
892
893C<collect_pod> is a optional boolean argument that determines whether POD
894data is collected and stored for reference.  POD data is not collected by
895default.  POD headings are always collected.
896
897If the file begins by an UTF-8, UTF-16BE or UTF-16LE byte-order mark, then
898it is skipped before processing, and the content of the file is also decoded
899appropriately starting from perl 5.8.
900
901Alternatively, if C<decode_pod> is set, it will decode the collected pod
902sections according to the C<=encoding> declaration.
903
904=head2 C<< new_from_handle($handle, $filename, collect_pod => 1, decode_pod => 1) >>
905
906This works just like C<new_from_file>, except that a handle can be provided
907as the first argument.
908
909Note that there is no validation to confirm that the handle is a handle or
910something that can act like one.  Passing something that isn't a handle will
911cause a exception when trying to read from it.  The C<filename> argument is
912mandatory or undef will be returned.
913
914You are responsible for setting the decoding layers on C<$handle> if
915required.
916
917=head2 C<< new_from_module($module, collect_pod => 1, inc => \@dirs, decode_pod => 1) >>
918
919Constructs a C<Module::Metadata> object given a module or package name.
920Returns undef if the module cannot be found.
921
922In addition to accepting the C<collect_pod> and C<decode_pod> arguments as
923described above, this method accepts a C<inc> argument which is a reference to
924an array of directories to search for the module.  If none are given, the
925default is @INC.
926
927If the file that contains the module begins by an UTF-8, UTF-16BE or
928UTF-16LE byte-order mark, then it is skipped before processing, and the
929content of the file is also decoded appropriately starting from perl 5.8.
930
931=head2 C<< find_module_by_name($module, \@dirs) >>
932
933Returns the path to a module given the module or package name. A list
934of directories can be passed in as an optional parameter, otherwise
935@INC is searched.
936
937Can be called as either an object or a class method.
938
939=head2 C<< find_module_dir_by_name($module, \@dirs) >>
940
941Returns the entry in C<@dirs> (or C<@INC> by default) that contains
942the module C<$module>. A list of directories can be passed in as an
943optional parameter, otherwise @INC is searched.
944
945Can be called as either an object or a class method.
946
947=head2 C<< provides( %options ) >>
948
949This is a convenience wrapper around C<package_versions_from_directory>
950to generate a CPAN META C<provides> data structure.  It takes key/value
951pairs.  Valid option keys include:
952
953=over
954
955=item version B<(required)>
956
957Specifies which version of the L<CPAN::Meta::Spec> should be used as
958the format of the C<provides> output.  Currently only '1.4' and '2'
959are supported (and their format is identical).  This may change in
960the future as the definition of C<provides> changes.
961
962The C<version> option is required.  If it is omitted or if
963an unsupported version is given, then C<provides> will throw an error.
964
965=item dir
966
967Directory to search recursively for F<.pm> files.  May not be specified with
968C<files>.
969
970=item files
971
972Array reference of files to examine.  May not be specified with C<dir>.
973
974=item prefix
975
976String to prepend to the C<file> field of the resulting output. This defaults
977to F<lib>, which is the common case for most CPAN distributions with their
978F<.pm> files in F<lib>.  This option ensures the META information has the
979correct relative path even when the C<dir> or C<files> arguments are
980absolute or have relative paths from a location other than the distribution
981root.
982
983=back
984
985For example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value
986is a hashref of the form:
987
988  {
989    'Package::Name' => {
990      version => '0.123',
991      file => 'lib/Package/Name.pm'
992    },
993    'OtherPackage::Name' => ...
994  }
995
996=head2 C<< package_versions_from_directory($dir, \@files?) >>
997
998Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
999for those files in C<$dir> - and reads each file for packages and versions,
1000returning a hashref of the form:
1001
1002  {
1003    'Package::Name' => {
1004      version => '0.123',
1005      file => 'Package/Name.pm'
1006    },
1007    'OtherPackage::Name' => ...
1008  }
1009
1010The C<DB> and C<main> packages are always omitted, as are any "private"
1011packages that have leading underscores in the namespace (e.g.
1012C<Foo::_private>)
1013
1014Note that the file path is relative to C<$dir> if that is specified.
1015This B<must not> be used directly for CPAN META C<provides>.  See
1016the C<provides> method instead.
1017
1018=head2 C<< log_info (internal) >>
1019
1020Used internally to perform logging; imported from Log::Contextual if
1021Log::Contextual has already been loaded, otherwise simply calls warn.
1022
1023=head1 OBJECT METHODS
1024
1025=head2 C<< name() >>
1026
1027Returns the name of the package represented by this module. If there
1028is more than one package, it makes a best guess based on the
1029filename. If it's a script (i.e. not a *.pm) the package name is
1030'main'.
1031
1032=head2 C<< version($package) >>
1033
1034Returns the version as defined by the $VERSION variable for the
1035package as returned by the C<name> method if no arguments are
1036given. If given the name of a package it will attempt to return the
1037version of that package if it is specified in the file.
1038
1039=head2 C<< filename() >>
1040
1041Returns the absolute path to the file.
1042Note that this file may not actually exist on disk yet, e.g. if the module was read from an in-memory filehandle.
1043
1044=head2 C<< packages_inside() >>
1045
1046Returns a list of packages. Note: this is a raw list of packages
1047discovered (or assumed, in the case of C<main>).  It is not
1048filtered for C<DB>, C<main> or private packages the way the
1049C<provides> method does.  Invalid package names are not returned,
1050for example "Foo:Bar".  Strange but valid package names are
1051returned, for example "Foo::Bar::", and are left up to the caller
1052on how to handle.
1053
1054=head2 C<< pod_inside() >>
1055
1056Returns a list of POD sections.
1057
1058=head2 C<< contains_pod() >>
1059
1060Returns true if there is any POD in the file.
1061
1062=head2 C<< pod($section) >>
1063
1064Returns the POD data in the given section.
1065
1066=head2 C<< is_indexable($package) >> or C<< is_indexable() >>
1067
1068Available since version 1.000020.
1069
1070Returns a boolean indicating whether the package (if provided) or any package
1071(otherwise) is eligible for indexing by PAUSE, the Perl Authors Upload Server.
1072Note This only checks for valid C<package> declarations, and does not take any
1073ownership information into account.
1074
1075=head1 SUPPORT
1076
1077Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Module-Metadata>
1078(or L<bug-Module-Metadata@rt.cpan.org|mailto:bug-Module-Metadata@rt.cpan.org>).
1079
1080There is also a mailing list available for users of this distribution, at
1081L<http://lists.perl.org/list/cpan-workers.html>.
1082
1083There is also an irc channel available for users of this distribution, at
1084L<C<#toolchain> on C<irc.perl.org>|irc://irc.perl.org/#toolchain>.
1085
1086=head1 AUTHOR
1087
1088Original code from Module::Build::ModuleInfo by Ken Williams
1089<kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
1090
1091Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
1092assistance from David Golden (xdg) <dagolden@cpan.org>.
1093
1094=head1 CONTRIBUTORS
1095
1096=for stopwords Karen Etheridge David Golden Vincent Pit Matt S Trout Chris Nehren Graham Knop Olivier Mengué Tomas Doran Christian Walde Craig A. Berry Tatsuhiko Miyagawa tokuhirom 'BinGOs' Williams Mitchell Steinbrunner Edward Zborowski Gareth Harper James Raspass Jerry D. Hedden Josh Jore Kent Fredric Leon Timmermans Peter Rabbitson Steve Hay
1097
1098=over 4
1099
1100=item *
1101
1102Karen Etheridge <ether@cpan.org>
1103
1104=item *
1105
1106David Golden <dagolden@cpan.org>
1107
1108=item *
1109
1110Vincent Pit <perl@profvince.com>
1111
1112=item *
1113
1114Matt S Trout <mst@shadowcat.co.uk>
1115
1116=item *
1117
1118Chris Nehren <apeiron@cpan.org>
1119
1120=item *
1121
1122Graham Knop <haarg@haarg.org>
1123
1124=item *
1125
1126Olivier Mengué <dolmen@cpan.org>
1127
1128=item *
1129
1130Tomas Doran <bobtfish@bobtfish.net>
1131
1132=item *
1133
1134Christian Walde <walde.christian@googlemail.com>
1135
1136=item *
1137
1138Craig A. Berry <cberry@cpan.org>
1139
1140=item *
1141
1142Tatsuhiko Miyagawa <miyagawa@bulknews.net>
1143
1144=item *
1145
1146tokuhirom <tokuhirom@gmail.com>
1147
1148=item *
1149
1150Chris 'BinGOs' Williams <chris@bingosnet.co.uk>
1151
1152=item *
1153
1154David Mitchell <davem@iabyn.com>
1155
1156=item *
1157
1158David Steinbrunner <dsteinbrunner@pobox.com>
1159
1160=item *
1161
1162Edward Zborowski <ed@rubensteintech.com>
1163
1164=item *
1165
1166Gareth Harper <gareth@broadbean.com>
1167
1168=item *
1169
1170James Raspass <jraspass@gmail.com>
1171
1172=item *
1173
1174Jerry D. Hedden <jdhedden@cpan.org>
1175
1176=item *
1177
1178Josh Jore <jjore@cpan.org>
1179
1180=item *
1181
1182Kent Fredric <kentnl@cpan.org>
1183
1184=item *
1185
1186Leon Timmermans <fawaka@gmail.com>
1187
1188=item *
1189
1190Peter Rabbitson <ribasushi@cpan.org>
1191
1192=item *
1193
1194Steve Hay <steve.m.hay@googlemail.com>
1195
1196=back
1197
1198=head1 COPYRIGHT & LICENSE
1199
1200Original code Copyright (c) 2001-2011 Ken Williams.
1201Additional code Copyright (c) 2010-2011 Matt Trout and David Golden.
1202All rights reserved.
1203
1204This library is free software; you can redistribute it and/or
1205modify it under the same terms as Perl itself.
1206
1207=cut
1208