xref: /openbsd-src/gnu/usr.bin/perl/cpan/Module-Metadata/lib/Module/Metadata.pm (revision 3d61058aa5c692477b6d18acfbbdb653a9930ff9)
1898184e3Ssthen# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
29f11ffb7Safresh1# vim:ts=8:sw=2:et:sta:sts=2:tw=78
3*3d61058aSafresh1package Module::Metadata; # git description: v1.000037-8-g92dec6c
4b8851fccSafresh1# ABSTRACT: Gather package and POD information from perl module files
5898184e3Ssthen
6898184e3Ssthen# Adapted from Perl-licensed code originally distributed with
7898184e3Ssthen# Module-Build by Ken Williams
8898184e3Ssthen
9898184e3Ssthen# This module provides routines to gather information about
10898184e3Ssthen# perl modules (assuming this may be expanded in the distant
11898184e3Ssthen# parrot future to look at other types of modules).
12898184e3Ssthen
13b8851fccSafresh1sub __clean_eval { eval $_[0] }
14898184e3Ssthenuse strict;
156fb12b70Safresh1use warnings;
166fb12b70Safresh1
17*3d61058aSafresh1our $VERSION = '1.000038';
18898184e3Ssthen
19898184e3Ssthenuse Carp qw/croak/;
20898184e3Ssthenuse File::Spec;
21b8851fccSafresh1BEGIN {
22b8851fccSafresh1       # Try really hard to not depend ony any DynaLoaded module, such as IO::File or Fcntl
23b8851fccSafresh1       eval {
24b8851fccSafresh1               require Fcntl; Fcntl->import('SEEK_SET'); 1;
25b8851fccSafresh1       } or *SEEK_SET = sub { 0 }
26b8851fccSafresh1}
27898184e3Ssthenuse version 0.87;
28898184e3SsthenBEGIN {
29898184e3Ssthen  if ($INC{'Log/Contextual.pm'}) {
30b8851fccSafresh1    require "Log/Contextual/WarnLogger.pm"; # Hide from AutoPrereqs
31b8851fccSafresh1    Log::Contextual->import('log_info',
32b8851fccSafresh1      '-default_logger' => Log::Contextual::WarnLogger->new({ env_prefix => 'MODULE_METADATA', }),
33b8851fccSafresh1    );
34b8851fccSafresh1  }
35b8851fccSafresh1  else {
36898184e3Ssthen    *log_info = sub (&) { warn $_[0]->() };
37898184e3Ssthen  }
38898184e3Ssthen}
39898184e3Ssthenuse File::Find qw(find);
40898184e3Ssthen
41898184e3Ssthenmy $V_NUM_REGEXP = qr{v?[0-9._]+};  # crudely, a v-string or decimal
42898184e3Ssthen
436fb12b70Safresh1my $PKG_FIRST_WORD_REGEXP = qr{ # the FIRST word in a package name
446fb12b70Safresh1  [a-zA-Z_]                     # the first word CANNOT start with a digit
456fb12b70Safresh1    (?:
466fb12b70Safresh1      [\w']?                    # can contain letters, digits, _, or ticks
476fb12b70Safresh1      \w                        # But, NO multi-ticks or trailing ticks
486fb12b70Safresh1    )*
496fb12b70Safresh1}x;
506fb12b70Safresh1
516fb12b70Safresh1my $PKG_ADDL_WORD_REGEXP = qr{ # the 2nd+ word in a package name
526fb12b70Safresh1  \w                           # the 2nd+ word CAN start with digits
536fb12b70Safresh1    (?:
546fb12b70Safresh1      [\w']?                   # and can contain letters or ticks
556fb12b70Safresh1      \w                       # But, NO multi-ticks or trailing ticks
566fb12b70Safresh1    )*
576fb12b70Safresh1}x;
586fb12b70Safresh1
596fb12b70Safresh1my $PKG_NAME_REGEXP = qr{ # match a package name
60b8851fccSafresh1  (?: :: )?               # a pkg name can start with arisdottle
616fb12b70Safresh1  $PKG_FIRST_WORD_REGEXP  # a package word
626fb12b70Safresh1  (?:
63b8851fccSafresh1    (?: :: )+             ### arisdottle (allow one or many times)
646fb12b70Safresh1    $PKG_ADDL_WORD_REGEXP ### a package word
656fb12b70Safresh1  )*                      # ^ zero, one or many times
666fb12b70Safresh1  (?:
67b8851fccSafresh1    ::                    # allow trailing arisdottle
686fb12b70Safresh1  )?
696fb12b70Safresh1}x;
706fb12b70Safresh1
71898184e3Ssthenmy $PKG_REGEXP  = qr{   # match a package declaration
72898184e3Ssthen  ^[\s\{;]*             # intro chars on a line
73898184e3Ssthen  package               # the word 'package'
74898184e3Ssthen  \s+                   # whitespace
756fb12b70Safresh1  ($PKG_NAME_REGEXP)    # a package name
76898184e3Ssthen  \s*                   # optional whitespace
77898184e3Ssthen  ($V_NUM_REGEXP)?      # optional version number
78*3d61058aSafresh1  \s*                   # optional whitespace
79898184e3Ssthen  [;\{]                 # semicolon line terminator or block start (since 5.16)
80898184e3Ssthen}x;
81898184e3Ssthen
82*3d61058aSafresh1my $CLASS_REGEXP = qr{  # match a class declaration (core since 5.38)
83*3d61058aSafresh1  ^[\s\{;]*             # intro chars on a line
84*3d61058aSafresh1  class                 # the word 'class'
85*3d61058aSafresh1  \s+                   # whitespace
86*3d61058aSafresh1  ($PKG_NAME_REGEXP)    # a package name
87*3d61058aSafresh1  \s*                   # optional whitespace
88*3d61058aSafresh1  ($V_NUM_REGEXP)?      # optional version number
89*3d61058aSafresh1  \s*                   # optional whitespace
90*3d61058aSafresh1  [;\{]                 # semicolon line terminator or block start
91*3d61058aSafresh1}x;
92*3d61058aSafresh1
93898184e3Ssthenmy $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
94898184e3Ssthen  ([\$*])         # sigil - $ or *
95898184e3Ssthen  (
96898184e3Ssthen    (             # optional leading package name
97b8851fccSafresh1      (?:::|\')?  # possibly starting like just :: (a la $::VERSION)
98898184e3Ssthen      (?:\w+(?:::|\'))*  # Foo::Bar:: ...
99898184e3Ssthen    )?
100898184e3Ssthen    VERSION
101898184e3Ssthen  )\b
102898184e3Ssthen}x;
103898184e3Ssthen
104898184e3Ssthenmy $VERS_REGEXP = qr{ # match a VERSION definition
105898184e3Ssthen  (?:
106898184e3Ssthen    \(\s*$VARNAME_REGEXP\s*\) # with parens
107898184e3Ssthen  |
108898184e3Ssthen    $VARNAME_REGEXP           # without parens
109898184e3Ssthen  )
110898184e3Ssthen  \s*
111b8851fccSafresh1  =[^=~>]  # = but not ==, nor =~, nor =>
112898184e3Ssthen}x;
113898184e3Ssthen
114898184e3Ssthensub new_from_file {
115898184e3Ssthen  my $class    = shift;
116898184e3Ssthen  my $filename = File::Spec->rel2abs( shift );
117898184e3Ssthen
118898184e3Ssthen  return undef unless defined( $filename ) && -f $filename;
119898184e3Ssthen  return $class->_init(undef, $filename, @_);
120898184e3Ssthen}
121898184e3Ssthen
122898184e3Ssthensub new_from_handle {
123898184e3Ssthen  my $class    = shift;
124898184e3Ssthen  my $handle   = shift;
125898184e3Ssthen  my $filename = shift;
126898184e3Ssthen  return undef unless defined($handle) && defined($filename);
127898184e3Ssthen  $filename = File::Spec->rel2abs( $filename );
128898184e3Ssthen
129898184e3Ssthen  return $class->_init(undef, $filename, @_, handle => $handle);
130898184e3Ssthen
131898184e3Ssthen}
132898184e3Ssthen
133898184e3Ssthen
134898184e3Ssthensub new_from_module {
135898184e3Ssthen  my $class   = shift;
136898184e3Ssthen  my $module  = shift;
137898184e3Ssthen  my %props   = @_;
138898184e3Ssthen
139898184e3Ssthen  $props{inc} ||= \@INC;
140898184e3Ssthen  my $filename = $class->find_module_by_name( $module, $props{inc} );
141898184e3Ssthen  return undef unless defined( $filename ) && -f $filename;
142898184e3Ssthen  return $class->_init($module, $filename, %props);
143898184e3Ssthen}
144898184e3Ssthen
145898184e3Ssthen{
146898184e3Ssthen
147898184e3Ssthen  my $compare_versions = sub {
148898184e3Ssthen    my ($v1, $op, $v2) = @_;
149898184e3Ssthen    $v1 = version->new($v1)
150898184e3Ssthen      unless UNIVERSAL::isa($v1,'version');
151898184e3Ssthen
152898184e3Ssthen    my $eval_str = "\$v1 $op \$v2";
153898184e3Ssthen    my $result   = eval $eval_str;
154898184e3Ssthen    log_info { "error comparing versions: '$eval_str' $@" } if $@;
155898184e3Ssthen
156898184e3Ssthen    return $result;
157898184e3Ssthen  };
158898184e3Ssthen
159898184e3Ssthen  my $normalize_version = sub {
160898184e3Ssthen    my ($version) = @_;
161898184e3Ssthen    if ( $version =~ /[=<>!,]/ ) { # logic, not just version
162898184e3Ssthen      # take as is without modification
163898184e3Ssthen    }
164898184e3Ssthen    elsif ( ref $version eq 'version' ) { # version objects
165898184e3Ssthen      $version = $version->is_qv ? $version->normal : $version->stringify;
166898184e3Ssthen    }
167898184e3Ssthen    elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
168898184e3Ssthen      # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
169898184e3Ssthen      $version = "v$version";
170898184e3Ssthen    }
171898184e3Ssthen    else {
172898184e3Ssthen      # leave alone
173898184e3Ssthen    }
174898184e3Ssthen    return $version;
175898184e3Ssthen  };
176898184e3Ssthen
177898184e3Ssthen  # separate out some of the conflict resolution logic
178898184e3Ssthen
179898184e3Ssthen  my $resolve_module_versions = sub {
180898184e3Ssthen    my $packages = shift;
181898184e3Ssthen
182898184e3Ssthen    my( $file, $version );
183898184e3Ssthen    my $err = '';
184898184e3Ssthen      foreach my $p ( @$packages ) {
185898184e3Ssthen        if ( defined( $p->{version} ) ) {
186898184e3Ssthen          if ( defined( $version ) ) {
187898184e3Ssthen            if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
188898184e3Ssthen              $err .= "  $p->{file} ($p->{version})\n";
189b8851fccSafresh1            }
190b8851fccSafresh1            else {
191898184e3Ssthen              # same version declared multiple times, ignore
192898184e3Ssthen            }
193b8851fccSafresh1          }
194b8851fccSafresh1          else {
195898184e3Ssthen            $file    = $p->{file};
196898184e3Ssthen            $version = $p->{version};
197898184e3Ssthen          }
198898184e3Ssthen        }
199898184e3Ssthen      $file ||= $p->{file} if defined( $p->{file} );
200898184e3Ssthen    }
201898184e3Ssthen
202898184e3Ssthen    if ( $err ) {
203898184e3Ssthen      $err = "  $file ($version)\n" . $err;
204898184e3Ssthen    }
205898184e3Ssthen
206898184e3Ssthen    my %result = (
207898184e3Ssthen      file    => $file,
208898184e3Ssthen      version => $version,
209898184e3Ssthen      err     => $err
210898184e3Ssthen    );
211898184e3Ssthen
212898184e3Ssthen    return \%result;
213898184e3Ssthen  };
214898184e3Ssthen
215898184e3Ssthen  sub provides {
216898184e3Ssthen    my $class = shift;
217898184e3Ssthen
218898184e3Ssthen    croak "provides() requires key/value pairs \n" if @_ % 2;
219898184e3Ssthen    my %args = @_;
220898184e3Ssthen
221898184e3Ssthen    croak "provides() takes only one of 'dir' or 'files'\n"
222898184e3Ssthen      if $args{dir} && $args{files};
223898184e3Ssthen
224898184e3Ssthen    croak "provides() requires a 'version' argument"
225898184e3Ssthen      unless defined $args{version};
226898184e3Ssthen
227898184e3Ssthen    croak "provides() does not support version '$args{version}' metadata"
228b46d8ef2Safresh1        unless grep $args{version} eq $_, qw/1.4 2/;
229898184e3Ssthen
230898184e3Ssthen    $args{prefix} = 'lib' unless defined $args{prefix};
231898184e3Ssthen
232898184e3Ssthen    my $p;
233898184e3Ssthen    if ( $args{dir} ) {
234898184e3Ssthen      $p = $class->package_versions_from_directory($args{dir});
235898184e3Ssthen    }
236898184e3Ssthen    else {
237898184e3Ssthen      croak "provides() requires 'files' to be an array reference\n"
238898184e3Ssthen        unless ref $args{files} eq 'ARRAY';
239898184e3Ssthen      $p = $class->package_versions_from_directory($args{files});
240898184e3Ssthen    }
241898184e3Ssthen
242898184e3Ssthen    # Now, fix up files with prefix
243898184e3Ssthen    if ( length $args{prefix} ) { # check in case disabled with q{}
244898184e3Ssthen      $args{prefix} =~ s{/$}{};
245898184e3Ssthen      for my $v ( values %$p ) {
246898184e3Ssthen        $v->{file} = "$args{prefix}/$v->{file}";
247898184e3Ssthen      }
248898184e3Ssthen    }
249898184e3Ssthen
250898184e3Ssthen    return $p
251898184e3Ssthen  }
252898184e3Ssthen
253898184e3Ssthen  sub package_versions_from_directory {
254898184e3Ssthen    my ( $class, $dir, $files ) = @_;
255898184e3Ssthen
256898184e3Ssthen    my @files;
257898184e3Ssthen
258898184e3Ssthen    if ( $files ) {
259898184e3Ssthen      @files = @$files;
260b8851fccSafresh1    }
261b8851fccSafresh1    else {
262898184e3Ssthen      find( {
263898184e3Ssthen        wanted => sub {
264898184e3Ssthen          push @files, $_ if -f $_ && /\.pm$/;
265898184e3Ssthen        },
266898184e3Ssthen        no_chdir => 1,
267898184e3Ssthen      }, $dir );
268898184e3Ssthen    }
269898184e3Ssthen
270898184e3Ssthen    # First, we enumerate all packages & versions,
271898184e3Ssthen    # separating into primary & alternative candidates
272898184e3Ssthen    my( %prime, %alt );
273898184e3Ssthen    foreach my $file (@files) {
274b46d8ef2Safresh1      my $mapped_filename = File::Spec->abs2rel( $file, $dir );
275b46d8ef2Safresh1      my @path = File::Spec->splitdir( $mapped_filename );
276898184e3Ssthen      (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
277898184e3Ssthen
278898184e3Ssthen      my $pm_info = $class->new_from_file( $file );
279898184e3Ssthen
280898184e3Ssthen      foreach my $package ( $pm_info->packages_inside ) {
281898184e3Ssthen        next if $package eq 'main';  # main can appear numerous times, ignore
282898184e3Ssthen        next if $package eq 'DB';    # special debugging package, ignore
283898184e3Ssthen        next if grep /^_/, split( /::/, $package ); # private package, ignore
284898184e3Ssthen
285898184e3Ssthen        my $version = $pm_info->version( $package );
286898184e3Ssthen
28791f110e0Safresh1        $prime_package = $package if lc($prime_package) eq lc($package);
288898184e3Ssthen        if ( $package eq $prime_package ) {
289898184e3Ssthen          if ( exists( $prime{$package} ) ) {
290898184e3Ssthen            croak "Unexpected conflict in '$package'; multiple versions found.\n";
291b8851fccSafresh1          }
292b8851fccSafresh1          else {
29391f110e0Safresh1            $mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename);
294898184e3Ssthen            $prime{$package}{file} = $mapped_filename;
295898184e3Ssthen            $prime{$package}{version} = $version if defined( $version );
296898184e3Ssthen          }
297b8851fccSafresh1        }
298b8851fccSafresh1        else {
299898184e3Ssthen          push( @{$alt{$package}}, {
300898184e3Ssthen                                    file    => $mapped_filename,
301898184e3Ssthen                                    version => $version,
302898184e3Ssthen                                   } );
303898184e3Ssthen        }
304898184e3Ssthen      }
305898184e3Ssthen    }
306898184e3Ssthen
307898184e3Ssthen    # Then we iterate over all the packages found above, identifying conflicts
308898184e3Ssthen    # and selecting the "best" candidate for recording the file & version
309898184e3Ssthen    # for each package.
310898184e3Ssthen    foreach my $package ( keys( %alt ) ) {
311898184e3Ssthen      my $result = $resolve_module_versions->( $alt{$package} );
312898184e3Ssthen
313898184e3Ssthen      if ( exists( $prime{$package} ) ) { # primary package selected
314898184e3Ssthen
315898184e3Ssthen        if ( $result->{err} ) {
316898184e3Ssthen        # Use the selected primary package, but there are conflicting
317898184e3Ssthen        # errors among multiple alternative packages that need to be
318898184e3Ssthen        # reported
319898184e3Ssthen          log_info {
320898184e3Ssthen            "Found conflicting versions for package '$package'\n" .
321898184e3Ssthen            "  $prime{$package}{file} ($prime{$package}{version})\n" .
322898184e3Ssthen            $result->{err}
323898184e3Ssthen          };
324898184e3Ssthen
325b8851fccSafresh1        }
326b8851fccSafresh1        elsif ( defined( $result->{version} ) ) {
327898184e3Ssthen        # There is a primary package selected, and exactly one
328898184e3Ssthen        # alternative package
329898184e3Ssthen
330898184e3Ssthen        if ( exists( $prime{$package}{version} ) &&
331898184e3Ssthen             defined( $prime{$package}{version} ) ) {
332898184e3Ssthen          # Unless the version of the primary package agrees with the
333898184e3Ssthen          # version of the alternative package, report a conflict
334898184e3Ssthen        if ( $compare_versions->(
335898184e3Ssthen                 $prime{$package}{version}, '!=', $result->{version}
336898184e3Ssthen               )
337898184e3Ssthen             ) {
338898184e3Ssthen
339898184e3Ssthen            log_info {
340898184e3Ssthen              "Found conflicting versions for package '$package'\n" .
341898184e3Ssthen              "  $prime{$package}{file} ($prime{$package}{version})\n" .
342898184e3Ssthen              "  $result->{file} ($result->{version})\n"
343898184e3Ssthen            };
344898184e3Ssthen          }
345898184e3Ssthen
346b8851fccSafresh1        }
347b8851fccSafresh1        else {
348898184e3Ssthen          # The prime package selected has no version so, we choose to
349898184e3Ssthen          # use any alternative package that does have a version
350898184e3Ssthen          $prime{$package}{file}    = $result->{file};
351898184e3Ssthen          $prime{$package}{version} = $result->{version};
352898184e3Ssthen        }
353898184e3Ssthen
354b8851fccSafresh1        }
355b8851fccSafresh1        else {
356898184e3Ssthen        # no alt package found with a version, but we have a prime
357898184e3Ssthen        # package so we use it whether it has a version or not
358898184e3Ssthen        }
359898184e3Ssthen
360b8851fccSafresh1      }
361b8851fccSafresh1      else { # No primary package was selected, use the best alternative
362898184e3Ssthen
363898184e3Ssthen        if ( $result->{err} ) {
364898184e3Ssthen          log_info {
365898184e3Ssthen            "Found conflicting versions for package '$package'\n" .
366898184e3Ssthen            $result->{err}
367898184e3Ssthen          };
368898184e3Ssthen        }
369898184e3Ssthen
370898184e3Ssthen        # Despite possible conflicting versions, we choose to record
371898184e3Ssthen        # something rather than nothing
372898184e3Ssthen        $prime{$package}{file}    = $result->{file};
373898184e3Ssthen        $prime{$package}{version} = $result->{version}
374898184e3Ssthen          if defined( $result->{version} );
375898184e3Ssthen      }
376898184e3Ssthen    }
377898184e3Ssthen
378898184e3Ssthen    # Normalize versions.  Can't use exists() here because of bug in YAML::Node.
3796fb12b70Safresh1    # XXX "bug in YAML::Node" comment seems irrelevant -- dagolden, 2009-05-18
380898184e3Ssthen    for (grep defined $_->{version}, values %prime) {
381898184e3Ssthen      $_->{version} = $normalize_version->( $_->{version} );
382898184e3Ssthen    }
383898184e3Ssthen
384898184e3Ssthen    return \%prime;
385898184e3Ssthen  }
386898184e3Ssthen}
387898184e3Ssthen
388898184e3Ssthen
389898184e3Ssthensub _init {
390898184e3Ssthen  my $class    = shift;
391898184e3Ssthen  my $module   = shift;
392898184e3Ssthen  my $filename = shift;
393898184e3Ssthen  my %props = @_;
394898184e3Ssthen
395898184e3Ssthen  my $handle = delete $props{handle};
396898184e3Ssthen  my( %valid_props, @valid_props );
39756d68f1eSafresh1  @valid_props = qw( collect_pod inc decode_pod );
398898184e3Ssthen  @valid_props{@valid_props} = delete( @props{@valid_props} );
399898184e3Ssthen  warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
400898184e3Ssthen
401898184e3Ssthen  my %data = (
402898184e3Ssthen    module       => $module,
403898184e3Ssthen    filename     => $filename,
404898184e3Ssthen    version      => undef,
405898184e3Ssthen    packages     => [],
406898184e3Ssthen    versions     => {},
407898184e3Ssthen    pod          => {},
408898184e3Ssthen    pod_headings => [],
409898184e3Ssthen    collect_pod  => 0,
410898184e3Ssthen
411898184e3Ssthen    %valid_props,
412898184e3Ssthen  );
413898184e3Ssthen
414898184e3Ssthen  my $self = bless(\%data, $class);
415898184e3Ssthen
416b8851fccSafresh1  if ( not $handle ) {
417b8851fccSafresh1    my $filename = $self->{filename};
418b8851fccSafresh1    open $handle, '<', $filename
419b8851fccSafresh1      or croak( "Can't open '$filename': $!" );
420b8851fccSafresh1
421b8851fccSafresh1    $self->_handle_bom($handle, $filename);
422b8851fccSafresh1  }
423898184e3Ssthen  $self->_parse_fh($handle);
424898184e3Ssthen
4259f11ffb7Safresh1  @{$self->{packages}} = __uniq(@{$self->{packages}});
4269f11ffb7Safresh1
427898184e3Ssthen  unless($self->{module} and length($self->{module})) {
4289f11ffb7Safresh1    # CAVEAT (possible TODO): .pmc files not treated the same as .pm
4299f11ffb7Safresh1    if ($self->{filename} =~ /\.pm$/) {
430898184e3Ssthen      my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
431898184e3Ssthen      $f =~ s/\..+$//;
4329f11ffb7Safresh1      my @candidates = grep /(^|::)$f$/, @{$self->{packages}};
4339f11ffb7Safresh1      $self->{module} = shift(@candidates); # this may be undef
434898184e3Ssthen    }
435898184e3Ssthen    else {
4369f11ffb7Safresh1      # this seems like an atrocious heuristic, albeit marginally better than
4379f11ffb7Safresh1      # what was here before. It should be rewritten entirely to be more like
4389f11ffb7Safresh1      # "if it's not a .pm file, it's not require()able as a name, therefore
4399f11ffb7Safresh1      # name() should be undef."
4409f11ffb7Safresh1      if ((grep /main/, @{$self->{packages}})
4419f11ffb7Safresh1          or (grep /main/, keys %{$self->{versions}})) {
442898184e3Ssthen        $self->{module} = 'main';
443898184e3Ssthen      }
4449f11ffb7Safresh1      else {
4459f11ffb7Safresh1        # TODO: this should maybe default to undef instead
4469f11ffb7Safresh1        $self->{module} = $self->{packages}[0] || '';
4479f11ffb7Safresh1      }
4489f11ffb7Safresh1    }
449898184e3Ssthen  }
450898184e3Ssthen
451898184e3Ssthen  $self->{version} = $self->{versions}{$self->{module}}
452898184e3Ssthen    if defined( $self->{module} );
453898184e3Ssthen
454898184e3Ssthen  return $self;
455898184e3Ssthen}
456898184e3Ssthen
457898184e3Ssthen# class method
458898184e3Ssthensub _do_find_module {
459898184e3Ssthen  my $class   = shift;
460898184e3Ssthen  my $module  = shift || croak 'find_module_by_name() requires a package name';
461898184e3Ssthen  my $dirs    = shift || \@INC;
462898184e3Ssthen
463898184e3Ssthen  my $file = File::Spec->catfile(split( /::/, $module));
464898184e3Ssthen  foreach my $dir ( @$dirs ) {
465898184e3Ssthen    my $testfile = File::Spec->catfile($dir, $file);
466898184e3Ssthen    return [ File::Spec->rel2abs( $testfile ), $dir ]
467898184e3Ssthen      if -e $testfile and !-d _;  # For stuff like ExtUtils::xsubpp
4689f11ffb7Safresh1    # CAVEAT (possible TODO): .pmc files are not discoverable here
469b8851fccSafresh1    $testfile .= '.pm';
470b8851fccSafresh1    return [ File::Spec->rel2abs( $testfile ), $dir ]
471b8851fccSafresh1      if -e $testfile;
472898184e3Ssthen  }
473898184e3Ssthen  return;
474898184e3Ssthen}
475898184e3Ssthen
476898184e3Ssthen# class method
477898184e3Ssthensub find_module_by_name {
478898184e3Ssthen  my $found = shift()->_do_find_module(@_) or return;
479898184e3Ssthen  return $found->[0];
480898184e3Ssthen}
481898184e3Ssthen
482898184e3Ssthen# class method
483898184e3Ssthensub find_module_dir_by_name {
484898184e3Ssthen  my $found = shift()->_do_find_module(@_) or return;
485898184e3Ssthen  return $found->[1];
486898184e3Ssthen}
487898184e3Ssthen
488898184e3Ssthen
489898184e3Ssthen# given a line of perl code, attempt to parse it if it looks like a
490898184e3Ssthen# $VERSION assignment, returning sigil, full name, & package name
491898184e3Ssthensub _parse_version_expression {
492898184e3Ssthen  my $self = shift;
493898184e3Ssthen  my $line = shift;
494898184e3Ssthen
495b8851fccSafresh1  my( $sigil, $variable_name, $package);
49691f110e0Safresh1  if ( $line =~ /$VERS_REGEXP/o ) {
497b8851fccSafresh1    ( $sigil, $variable_name, $package) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
498b8851fccSafresh1    if ( $package ) {
499b8851fccSafresh1      $package = ($package eq '::') ? 'main' : $package;
500b8851fccSafresh1      $package =~ s/::$//;
501898184e3Ssthen    }
502898184e3Ssthen  }
503898184e3Ssthen
504b8851fccSafresh1  return ( $sigil, $variable_name, $package );
505898184e3Ssthen}
506898184e3Ssthen
50791f110e0Safresh1# Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream.
50891f110e0Safresh1# If there's one, then skip it and set the :encoding layer appropriately.
50991f110e0Safresh1sub _handle_bom {
51091f110e0Safresh1  my ($self, $fh, $filename) = @_;
51191f110e0Safresh1
512b8851fccSafresh1  my $pos = tell $fh;
51391f110e0Safresh1  return unless defined $pos;
51491f110e0Safresh1
51591f110e0Safresh1  my $buf = ' ' x 2;
516b8851fccSafresh1  my $count = read $fh, $buf, length $buf;
51791f110e0Safresh1  return unless defined $count and $count >= 2;
51891f110e0Safresh1
51991f110e0Safresh1  my $encoding;
52091f110e0Safresh1  if ( $buf eq "\x{FE}\x{FF}" ) {
52191f110e0Safresh1    $encoding = 'UTF-16BE';
522b8851fccSafresh1  }
523b8851fccSafresh1  elsif ( $buf eq "\x{FF}\x{FE}" ) {
52491f110e0Safresh1    $encoding = 'UTF-16LE';
525b8851fccSafresh1  }
526b8851fccSafresh1  elsif ( $buf eq "\x{EF}\x{BB}" ) {
52791f110e0Safresh1    $buf = ' ';
528b8851fccSafresh1    $count = read $fh, $buf, length $buf;
52991f110e0Safresh1    if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) {
53091f110e0Safresh1      $encoding = 'UTF-8';
53191f110e0Safresh1    }
53291f110e0Safresh1  }
53391f110e0Safresh1
53491f110e0Safresh1  if ( defined $encoding ) {
53591f110e0Safresh1    if ( "$]" >= 5.008 ) {
53691f110e0Safresh1      binmode( $fh, ":encoding($encoding)" );
53791f110e0Safresh1    }
538b8851fccSafresh1  }
539b8851fccSafresh1  else {
540b8851fccSafresh1    seek $fh, $pos, SEEK_SET
54191f110e0Safresh1      or croak( sprintf "Can't reset position to the top of '$filename'" );
54291f110e0Safresh1  }
54391f110e0Safresh1
54491f110e0Safresh1  return $encoding;
54591f110e0Safresh1}
54691f110e0Safresh1
547898184e3Ssthensub _parse_fh {
548898184e3Ssthen  my ($self, $fh) = @_;
549898184e3Ssthen
550898184e3Ssthen  my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
551b8851fccSafresh1  my( @packages, %vers, %pod, @pod );
552b8851fccSafresh1  my $package = 'main';
553898184e3Ssthen  my $pod_sect = '';
554898184e3Ssthen  my $pod_data = '';
5556fb12b70Safresh1  my $in_end = 0;
55656d68f1eSafresh1  my $encoding = '';
557898184e3Ssthen
558898184e3Ssthen  while (defined( my $line = <$fh> )) {
559898184e3Ssthen    my $line_num = $.;
560898184e3Ssthen
561898184e3Ssthen    chomp( $line );
562898184e3Ssthen
56391f110e0Safresh1    # From toke.c : any line that begins by "=X", where X is an alphabetic
56491f110e0Safresh1    # character, introduces a POD segment.
56591f110e0Safresh1    my $is_cut;
56691f110e0Safresh1    if ( $line =~ /^=([a-zA-Z].*)/ ) {
56791f110e0Safresh1      my $cmd = $1;
56891f110e0Safresh1      # Then it goes back to Perl code for "=cutX" where X is a non-alphabetic
56991f110e0Safresh1      # character (which includes the newline, but here we chomped it away).
57091f110e0Safresh1      $is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/;
57191f110e0Safresh1      $in_pod = !$is_cut;
57291f110e0Safresh1    }
573898184e3Ssthen
57491f110e0Safresh1    if ( $in_pod ) {
575898184e3Ssthen
57691f110e0Safresh1      if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) {
577898184e3Ssthen        push( @pod, $1 );
578898184e3Ssthen        if ( $self->{collect_pod} && length( $pod_data ) ) {
579898184e3Ssthen          $pod{$pod_sect} = $pod_data;
580898184e3Ssthen          $pod_data = '';
581898184e3Ssthen        }
582898184e3Ssthen        $pod_sect = $1;
583898184e3Ssthen      }
584b8851fccSafresh1      elsif ( $self->{collect_pod} ) {
58556d68f1eSafresh1        if ( $self->{decode_pod} && $line =~ /^=encoding ([\w-]+)/ ) {
58656d68f1eSafresh1          $encoding = $1;
58756d68f1eSafresh1        }
588b8851fccSafresh1        $pod_data .= "$line\n";
589b8851fccSafresh1      }
590b8851fccSafresh1      next;
591b8851fccSafresh1    }
592b8851fccSafresh1    elsif ( $is_cut ) {
59391f110e0Safresh1      if ( $self->{collect_pod} && length( $pod_data ) ) {
59491f110e0Safresh1        $pod{$pod_sect} = $pod_data;
59591f110e0Safresh1        $pod_data = '';
59691f110e0Safresh1      }
59791f110e0Safresh1      $pod_sect = '';
598b8851fccSafresh1      next;
599b8851fccSafresh1    }
600898184e3Ssthen
6016fb12b70Safresh1    # Skip after __END__
6026fb12b70Safresh1    next if $in_end;
6036fb12b70Safresh1
60491f110e0Safresh1    # Skip comments in code
60591f110e0Safresh1    next if $line =~ /^\s*#/;
60691f110e0Safresh1
60791f110e0Safresh1    # Would be nice if we could also check $in_string or something too
6086fb12b70Safresh1    if ($line eq '__END__') {
6096fb12b70Safresh1      $in_end++;
6106fb12b70Safresh1      next;
6116fb12b70Safresh1    }
612b8851fccSafresh1
6136fb12b70Safresh1    last if $line eq '__DATA__';
614898184e3Ssthen
615898184e3Ssthen    # parse $line to see if it's a $VERSION declaration
616b8851fccSafresh1    my( $version_sigil, $version_fullname, $version_package ) =
617b8851fccSafresh1      index($line, 'VERSION') >= 1
61891f110e0Safresh1        ? $self->_parse_version_expression( $line )
61991f110e0Safresh1        : ();
620898184e3Ssthen
621*3d61058aSafresh1    if ( $line =~ /$PKG_REGEXP/o or $line =~ /$CLASS_REGEXP/ ) {
622b8851fccSafresh1      $package = $1;
623b8851fccSafresh1      my $version = $2;
624b8851fccSafresh1      push( @packages, $package ) unless grep( $package eq $_, @packages );
625b8851fccSafresh1      $need_vers = defined $version ? 0 : 1;
626b8851fccSafresh1
627b8851fccSafresh1      if ( not exists $vers{$package} and defined $version ){
628b8851fccSafresh1        # Upgrade to a version object.
629b8851fccSafresh1        my $dwim_version = eval { _dwim_version($version) };
630b8851fccSafresh1        croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n"
631b8851fccSafresh1          unless defined $dwim_version;  # "0" is OK!
632b8851fccSafresh1        $vers{$package} = $dwim_version;
633b8851fccSafresh1      }
634b8851fccSafresh1    }
635898184e3Ssthen
636898184e3Ssthen    # VERSION defined with full package spec, i.e. $Module::VERSION
637b8851fccSafresh1    elsif ( $version_fullname && $version_package ) {
638b8851fccSafresh1      # we do NOT save this package in found @packages
639b8851fccSafresh1      $need_vers = 0 if $version_package eq $package;
640898184e3Ssthen
641b8851fccSafresh1      unless ( defined $vers{$version_package} && length $vers{$version_package} ) {
642b8851fccSafresh1        $vers{$version_package} = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
643b8851fccSafresh1      }
644898184e3Ssthen    }
645898184e3Ssthen
646898184e3Ssthen    # first non-comment line in undeclared package main is VERSION
647b8851fccSafresh1    elsif ( $package eq 'main' && $version_fullname && !exists($vers{main}) ) {
648898184e3Ssthen      $need_vers = 0;
649b8851fccSafresh1      my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
650b8851fccSafresh1      $vers{$package} = $v;
651b8851fccSafresh1      push( @packages, 'main' );
652b8851fccSafresh1    }
653898184e3Ssthen
654898184e3Ssthen    # first non-comment line in undeclared package defines package main
655b8851fccSafresh1    elsif ( $package eq 'main' && !exists($vers{main}) && $line =~ /\w/ ) {
656898184e3Ssthen      $need_vers = 1;
657898184e3Ssthen      $vers{main} = '';
658b8851fccSafresh1      push( @packages, 'main' );
659b8851fccSafresh1    }
660898184e3Ssthen
661898184e3Ssthen    # only keep if this is the first $VERSION seen
662b8851fccSafresh1    elsif ( $version_fullname && $need_vers ) {
663898184e3Ssthen      $need_vers = 0;
664b8851fccSafresh1      my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line );
665898184e3Ssthen
666b8851fccSafresh1      unless ( defined $vers{$package} && length $vers{$package} ) {
667b8851fccSafresh1        $vers{$package} = $v;
668898184e3Ssthen      }
669898184e3Ssthen    }
670b8851fccSafresh1  } # end loop over each line
671898184e3Ssthen
672898184e3Ssthen  if ( $self->{collect_pod} && length($pod_data) ) {
673898184e3Ssthen    $pod{$pod_sect} = $pod_data;
674898184e3Ssthen  }
675898184e3Ssthen
67656d68f1eSafresh1  if ( $self->{decode_pod} && $encoding ) {
67756d68f1eSafresh1    require Encode;
67856d68f1eSafresh1    $_ = Encode::decode( $encoding, $_ ) for values %pod;
67956d68f1eSafresh1  }
68056d68f1eSafresh1
681898184e3Ssthen  $self->{versions} = \%vers;
682b8851fccSafresh1  $self->{packages} = \@packages;
683898184e3Ssthen  $self->{pod} = \%pod;
684898184e3Ssthen  $self->{pod_headings} = \@pod;
685898184e3Ssthen}
686898184e3Ssthen
6879f11ffb7Safresh1sub __uniq (@)
6889f11ffb7Safresh1{
6899f11ffb7Safresh1    my (%seen, $key);
690b46d8ef2Safresh1    grep !$seen{ $key = $_ }++, @_;
6919f11ffb7Safresh1}
6929f11ffb7Safresh1
693898184e3Ssthen{
694898184e3Ssthenmy $pn = 0;
695898184e3Ssthensub _evaluate_version_line {
696898184e3Ssthen  my $self = shift;
697b8851fccSafresh1  my( $sigil, $variable_name, $line ) = @_;
698898184e3Ssthen
699b8851fccSafresh1  # We compile into a local sub because 'use version' would cause
700898184e3Ssthen  # compiletime/runtime issues with local()
701898184e3Ssthen  $pn++; # everybody gets their own package
702b8851fccSafresh1  my $eval = qq{ my \$dummy = q#  Hide from _packages_inside()
703b8851fccSafresh1    #; package Module::Metadata::_version::p${pn};
704898184e3Ssthen    use version;
705b8851fccSafresh1    sub {
706b8851fccSafresh1      local $sigil$variable_name;
707898184e3Ssthen      $line;
708b8851fccSafresh1      return \$$variable_name if defined \$$variable_name;
709b8851fccSafresh1      return \$Module::Metadata::_version::p${pn}::$variable_name;
710898184e3Ssthen    };
711b8851fccSafresh1  };
712898184e3Ssthen
7136fb12b70Safresh1  $eval = $1 if $eval =~ m{^(.+)}s;
7146fb12b70Safresh1
715898184e3Ssthen  local $^W;
716898184e3Ssthen  # Try to get the $VERSION
717b8851fccSafresh1  my $vsub = __clean_eval($eval);
718b8851fccSafresh1  # some modules say $VERSION <equal sign> $Foo::Bar::VERSION, but Foo::Bar isn't
719898184e3Ssthen  # installed, so we need to hunt in ./lib for it
720898184e3Ssthen  if ( $@ =~ /Can't locate/ && -d 'lib' ) {
721898184e3Ssthen    local @INC = ('lib',@INC);
722b8851fccSafresh1    $vsub = __clean_eval($eval);
723898184e3Ssthen  }
724898184e3Ssthen  warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
725898184e3Ssthen    if $@;
726b8851fccSafresh1
727898184e3Ssthen  (ref($vsub) eq 'CODE') or
728898184e3Ssthen    croak "failed to build version sub for $self->{filename}";
729b8851fccSafresh1
730898184e3Ssthen  my $result = eval { $vsub->() };
731b8851fccSafresh1  # FIXME: $eval is not the right thing to print here
732898184e3Ssthen  croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
733898184e3Ssthen    if $@;
734898184e3Ssthen
735898184e3Ssthen  # Upgrade it into a version object
736898184e3Ssthen  my $version = eval { _dwim_version($result) };
737898184e3Ssthen
738b8851fccSafresh1  # FIXME: $eval is not the right thing to print here
739898184e3Ssthen  croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
740898184e3Ssthen    unless defined $version; # "0" is OK!
741898184e3Ssthen
742898184e3Ssthen  return $version;
743898184e3Ssthen}
744898184e3Ssthen}
745898184e3Ssthen
746898184e3Ssthen# Try to DWIM when things fail the lax version test in obvious ways
747898184e3Ssthen{
748898184e3Ssthen  my @version_prep = (
749898184e3Ssthen    # Best case, it just works
750898184e3Ssthen    sub { return shift },
751898184e3Ssthen
752898184e3Ssthen    # If we still don't have a version, try stripping any
753898184e3Ssthen    # trailing junk that is prohibited by lax rules
754898184e3Ssthen    sub {
755898184e3Ssthen      my $v = shift;
756898184e3Ssthen      $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
757898184e3Ssthen      return $v;
758898184e3Ssthen    },
759898184e3Ssthen
760898184e3Ssthen    # Activestate apparently creates custom versions like '1.23_45_01', which
761898184e3Ssthen    # cause version.pm to think it's an invalid alpha.  So check for that
762898184e3Ssthen    # and strip them
763898184e3Ssthen    sub {
764898184e3Ssthen      my $v = shift;
765898184e3Ssthen      my $num_dots = () = $v =~ m{(\.)}g;
766898184e3Ssthen      my $num_unders = () = $v =~ m{(_)}g;
767898184e3Ssthen      my $leading_v = substr($v,0,1) eq 'v';
768898184e3Ssthen      if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
769898184e3Ssthen        $v =~ s{_}{}g;
770898184e3Ssthen        $num_unders = () = $v =~ m{(_)}g;
771898184e3Ssthen      }
772898184e3Ssthen      return $v;
773898184e3Ssthen    },
774898184e3Ssthen
775898184e3Ssthen    # Worst case, try numifying it like we would have before version objects
776898184e3Ssthen    sub {
777898184e3Ssthen      my $v = shift;
778898184e3Ssthen      no warnings 'numeric';
779898184e3Ssthen      return 0 + $v;
780898184e3Ssthen    },
781898184e3Ssthen
782898184e3Ssthen  );
783898184e3Ssthen
784898184e3Ssthen  sub _dwim_version {
785898184e3Ssthen    my ($result) = shift;
786898184e3Ssthen
787898184e3Ssthen    return $result if ref($result) eq 'version';
788898184e3Ssthen
789898184e3Ssthen    my ($version, $error);
790898184e3Ssthen    for my $f (@version_prep) {
791898184e3Ssthen      $result = $f->($result);
792898184e3Ssthen      $version = eval { version->new($result) };
793898184e3Ssthen      $error ||= $@ if $@; # capture first failure
794898184e3Ssthen      last if defined $version;
795898184e3Ssthen    }
796898184e3Ssthen
797898184e3Ssthen    croak $error unless defined $version;
798898184e3Ssthen
799898184e3Ssthen    return $version;
800898184e3Ssthen  }
801898184e3Ssthen}
802898184e3Ssthen
803898184e3Ssthen############################################################
804898184e3Ssthen
805898184e3Ssthen# accessors
806898184e3Ssthensub name            { $_[0]->{module}            }
807898184e3Ssthen
808898184e3Ssthensub filename        { $_[0]->{filename}          }
809898184e3Ssthensub packages_inside { @{$_[0]->{packages}}       }
810898184e3Ssthensub pod_inside      { @{$_[0]->{pod_headings}}   }
8116fb12b70Safresh1sub contains_pod    { 0+@{$_[0]->{pod_headings}} }
812898184e3Ssthen
813898184e3Ssthensub version {
814898184e3Ssthen    my $self = shift;
815898184e3Ssthen    my $mod  = shift || $self->{module};
816898184e3Ssthen    my $vers;
817898184e3Ssthen    if ( defined( $mod ) && length( $mod ) &&
818898184e3Ssthen         exists( $self->{versions}{$mod} ) ) {
819898184e3Ssthen        return $self->{versions}{$mod};
820b8851fccSafresh1    }
821b8851fccSafresh1    else {
822898184e3Ssthen        return undef;
823898184e3Ssthen    }
824898184e3Ssthen}
825898184e3Ssthen
826898184e3Ssthensub pod {
827898184e3Ssthen    my $self = shift;
828898184e3Ssthen    my $sect = shift;
829898184e3Ssthen    if ( defined( $sect ) && length( $sect ) &&
830898184e3Ssthen         exists( $self->{pod}{$sect} ) ) {
831898184e3Ssthen        return $self->{pod}{$sect};
832b8851fccSafresh1    }
833b8851fccSafresh1    else {
834898184e3Ssthen        return undef;
835898184e3Ssthen    }
836898184e3Ssthen}
837898184e3Ssthen
838b8851fccSafresh1sub is_indexable {
839b8851fccSafresh1  my ($self, $package) = @_;
840b8851fccSafresh1
841b46d8ef2Safresh1  my @indexable_packages = grep $_ ne 'main', $self->packages_inside;
842b8851fccSafresh1
843b8851fccSafresh1  # check for specific package, if provided
844b46d8ef2Safresh1  return !! grep $_ eq $package, @indexable_packages if $package;
845b8851fccSafresh1
846b8851fccSafresh1  # otherwise, check for any indexable packages at all
847b8851fccSafresh1  return !! @indexable_packages;
848b8851fccSafresh1}
849b8851fccSafresh1
850898184e3Ssthen1;
851898184e3Ssthen
852b8851fccSafresh1__END__
853b8851fccSafresh1
854b8851fccSafresh1=pod
855b8851fccSafresh1
856b8851fccSafresh1=encoding UTF-8
857b8851fccSafresh1
858898184e3Ssthen=head1 NAME
859898184e3Ssthen
860898184e3SsthenModule::Metadata - Gather package and POD information from perl module files
861898184e3Ssthen
862b8851fccSafresh1=head1 VERSION
863b8851fccSafresh1
864*3d61058aSafresh1version 1.000038
865b8851fccSafresh1
866898184e3Ssthen=head1 SYNOPSIS
867898184e3Ssthen
868898184e3Ssthen  use Module::Metadata;
869898184e3Ssthen
870898184e3Ssthen  # information about a .pm file
871898184e3Ssthen  my $info = Module::Metadata->new_from_file( $file );
872898184e3Ssthen  my $version = $info->version;
873898184e3Ssthen
874898184e3Ssthen  # CPAN META 'provides' field for .pm files in a directory
875898184e3Ssthen  my $provides = Module::Metadata->provides(
876898184e3Ssthen    dir => 'lib', version => 2
877898184e3Ssthen  );
878898184e3Ssthen
879898184e3Ssthen=head1 DESCRIPTION
880898184e3Ssthen
8816fb12b70Safresh1This module provides a standard way to gather metadata about a .pm file through
8826fb12b70Safresh1(mostly) static analysis and (some) code execution.  When determining the
8836fb12b70Safresh1version of a module, the C<$VERSION> assignment is C<eval>ed, as is traditional
8846fb12b70Safresh1in the CPAN toolchain.
885898184e3Ssthen
886b8851fccSafresh1=head1 CLASS METHODS
887898184e3Ssthen
88856d68f1eSafresh1=head2 C<< new_from_file($filename, collect_pod => 1, decode_pod => 1) >>
889898184e3Ssthen
89091f110e0Safresh1Constructs a C<Module::Metadata> object given the path to a file.  Returns
89191f110e0Safresh1undef if the filename does not exist.
89291f110e0Safresh1
89391f110e0Safresh1C<collect_pod> is a optional boolean argument that determines whether POD
894898184e3Ssthendata is collected and stored for reference.  POD data is not collected by
89591f110e0Safresh1default.  POD headings are always collected.
89691f110e0Safresh1
89791f110e0Safresh1If the file begins by an UTF-8, UTF-16BE or UTF-16LE byte-order mark, then
89891f110e0Safresh1it is skipped before processing, and the content of the file is also decoded
89991f110e0Safresh1appropriately starting from perl 5.8.
900898184e3Ssthen
90156d68f1eSafresh1Alternatively, if C<decode_pod> is set, it will decode the collected pod
90256d68f1eSafresh1sections according to the C<=encoding> declaration.
90356d68f1eSafresh1
90456d68f1eSafresh1=head2 C<< new_from_handle($handle, $filename, collect_pod => 1, decode_pod => 1) >>
905898184e3Ssthen
906898184e3SsthenThis works just like C<new_from_file>, except that a handle can be provided
90791f110e0Safresh1as the first argument.
90891f110e0Safresh1
90991f110e0Safresh1Note that there is no validation to confirm that the handle is a handle or
91091f110e0Safresh1something that can act like one.  Passing something that isn't a handle will
91191f110e0Safresh1cause a exception when trying to read from it.  The C<filename> argument is
91291f110e0Safresh1mandatory or undef will be returned.
91391f110e0Safresh1
91491f110e0Safresh1You are responsible for setting the decoding layers on C<$handle> if
91591f110e0Safresh1required.
916898184e3Ssthen
91756d68f1eSafresh1=head2 C<< new_from_module($module, collect_pod => 1, inc => \@dirs, decode_pod => 1) >>
918898184e3Ssthen
91991f110e0Safresh1Constructs a C<Module::Metadata> object given a module or package name.
92091f110e0Safresh1Returns undef if the module cannot be found.
92191f110e0Safresh1
92256d68f1eSafresh1In addition to accepting the C<collect_pod> and C<decode_pod> arguments as
92356d68f1eSafresh1described above, this method accepts a C<inc> argument which is a reference to
92456d68f1eSafresh1an array of directories to search for the module.  If none are given, the
92556d68f1eSafresh1default is @INC.
92691f110e0Safresh1
92791f110e0Safresh1If the file that contains the module begins by an UTF-8, UTF-16BE or
92891f110e0Safresh1UTF-16LE byte-order mark, then it is skipped before processing, and the
92991f110e0Safresh1content of the file is also decoded appropriately starting from perl 5.8.
930898184e3Ssthen
931b8851fccSafresh1=head2 C<< find_module_by_name($module, \@dirs) >>
932898184e3Ssthen
933898184e3SsthenReturns the path to a module given the module or package name. A list
934898184e3Ssthenof directories can be passed in as an optional parameter, otherwise
935898184e3Ssthen@INC is searched.
936898184e3Ssthen
937898184e3SsthenCan be called as either an object or a class method.
938898184e3Ssthen
939b8851fccSafresh1=head2 C<< find_module_dir_by_name($module, \@dirs) >>
940898184e3Ssthen
941898184e3SsthenReturns the entry in C<@dirs> (or C<@INC> by default) that contains
942898184e3Ssthenthe module C<$module>. A list of directories can be passed in as an
943898184e3Ssthenoptional parameter, otherwise @INC is searched.
944898184e3Ssthen
945898184e3SsthenCan be called as either an object or a class method.
946898184e3Ssthen
947b8851fccSafresh1=head2 C<< provides( %options ) >>
948898184e3Ssthen
949898184e3SsthenThis is a convenience wrapper around C<package_versions_from_directory>
950898184e3Ssthento generate a CPAN META C<provides> data structure.  It takes key/value
951898184e3Ssthenpairs.  Valid option keys include:
952898184e3Ssthen
953898184e3Ssthen=over
954898184e3Ssthen
955898184e3Ssthen=item version B<(required)>
956898184e3Ssthen
957898184e3SsthenSpecifies which version of the L<CPAN::Meta::Spec> should be used as
958898184e3Ssthenthe format of the C<provides> output.  Currently only '1.4' and '2'
959898184e3Ssthenare supported (and their format is identical).  This may change in
960898184e3Ssthenthe future as the definition of C<provides> changes.
961898184e3Ssthen
962898184e3SsthenThe C<version> option is required.  If it is omitted or if
963898184e3Ssthenan unsupported version is given, then C<provides> will throw an error.
964898184e3Ssthen
965898184e3Ssthen=item dir
966898184e3Ssthen
967898184e3SsthenDirectory to search recursively for F<.pm> files.  May not be specified with
968898184e3SsthenC<files>.
969898184e3Ssthen
970898184e3Ssthen=item files
971898184e3Ssthen
972898184e3SsthenArray reference of files to examine.  May not be specified with C<dir>.
973898184e3Ssthen
974898184e3Ssthen=item prefix
975898184e3Ssthen
976898184e3SsthenString to prepend to the C<file> field of the resulting output. This defaults
977898184e3Ssthento F<lib>, which is the common case for most CPAN distributions with their
978898184e3SsthenF<.pm> files in F<lib>.  This option ensures the META information has the
979898184e3Ssthencorrect relative path even when the C<dir> or C<files> arguments are
980898184e3Ssthenabsolute or have relative paths from a location other than the distribution
981898184e3Ssthenroot.
982898184e3Ssthen
983898184e3Ssthen=back
984898184e3Ssthen
985898184e3SsthenFor example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value
986898184e3Ssthenis a hashref of the form:
987898184e3Ssthen
988898184e3Ssthen  {
989898184e3Ssthen    'Package::Name' => {
990898184e3Ssthen      version => '0.123',
991898184e3Ssthen      file => 'lib/Package/Name.pm'
992898184e3Ssthen    },
993898184e3Ssthen    'OtherPackage::Name' => ...
994898184e3Ssthen  }
995898184e3Ssthen
996b8851fccSafresh1=head2 C<< package_versions_from_directory($dir, \@files?) >>
997898184e3Ssthen
998898184e3SsthenScans C<$dir> for .pm files (unless C<@files> is given, in which case looks
999898184e3Ssthenfor those files in C<$dir> - and reads each file for packages and versions,
1000898184e3Ssthenreturning a hashref of the form:
1001898184e3Ssthen
1002898184e3Ssthen  {
1003898184e3Ssthen    'Package::Name' => {
1004898184e3Ssthen      version => '0.123',
1005898184e3Ssthen      file => 'Package/Name.pm'
1006898184e3Ssthen    },
1007898184e3Ssthen    'OtherPackage::Name' => ...
1008898184e3Ssthen  }
1009898184e3Ssthen
1010898184e3SsthenThe C<DB> and C<main> packages are always omitted, as are any "private"
1011898184e3Ssthenpackages that have leading underscores in the namespace (e.g.
1012898184e3SsthenC<Foo::_private>)
1013898184e3Ssthen
1014898184e3SsthenNote that the file path is relative to C<$dir> if that is specified.
1015898184e3SsthenThis B<must not> be used directly for CPAN META C<provides>.  See
1016898184e3Ssthenthe C<provides> method instead.
1017898184e3Ssthen
1018b8851fccSafresh1=head2 C<< log_info (internal) >>
1019898184e3Ssthen
1020898184e3SsthenUsed internally to perform logging; imported from Log::Contextual if
1021898184e3SsthenLog::Contextual has already been loaded, otherwise simply calls warn.
1022898184e3Ssthen
1023b8851fccSafresh1=head1 OBJECT METHODS
1024898184e3Ssthen
1025b8851fccSafresh1=head2 C<< name() >>
1026898184e3Ssthen
1027898184e3SsthenReturns the name of the package represented by this module. If there
1028b8851fccSafresh1is more than one package, it makes a best guess based on the
1029898184e3Ssthenfilename. If it's a script (i.e. not a *.pm) the package name is
1030898184e3Ssthen'main'.
1031898184e3Ssthen
1032b8851fccSafresh1=head2 C<< version($package) >>
1033898184e3Ssthen
1034898184e3SsthenReturns the version as defined by the $VERSION variable for the
1035898184e3Ssthenpackage as returned by the C<name> method if no arguments are
1036898184e3Ssthengiven. If given the name of a package it will attempt to return the
1037898184e3Ssthenversion of that package if it is specified in the file.
1038898184e3Ssthen
1039b8851fccSafresh1=head2 C<< filename() >>
1040898184e3Ssthen
1041898184e3SsthenReturns the absolute path to the file.
1042b8851fccSafresh1Note that this file may not actually exist on disk yet, e.g. if the module was read from an in-memory filehandle.
1043898184e3Ssthen
1044b8851fccSafresh1=head2 C<< packages_inside() >>
1045898184e3Ssthen
1046898184e3SsthenReturns a list of packages. Note: this is a raw list of packages
1047898184e3Ssthendiscovered (or assumed, in the case of C<main>).  It is not
1048898184e3Ssthenfiltered for C<DB>, C<main> or private packages the way the
10496fb12b70Safresh1C<provides> method does.  Invalid package names are not returned,
10506fb12b70Safresh1for example "Foo:Bar".  Strange but valid package names are
10516fb12b70Safresh1returned, for example "Foo::Bar::", and are left up to the caller
10526fb12b70Safresh1on how to handle.
1053898184e3Ssthen
1054b8851fccSafresh1=head2 C<< pod_inside() >>
1055898184e3Ssthen
1056898184e3SsthenReturns a list of POD sections.
1057898184e3Ssthen
1058b8851fccSafresh1=head2 C<< contains_pod() >>
1059898184e3Ssthen
1060898184e3SsthenReturns true if there is any POD in the file.
1061898184e3Ssthen
1062b8851fccSafresh1=head2 C<< pod($section) >>
1063898184e3Ssthen
1064898184e3SsthenReturns the POD data in the given section.
1065898184e3Ssthen
1066b8851fccSafresh1=head2 C<< is_indexable($package) >> or C<< is_indexable() >>
1067b8851fccSafresh1
1068b8851fccSafresh1Available since version 1.000020.
1069b8851fccSafresh1
1070b8851fccSafresh1Returns a boolean indicating whether the package (if provided) or any package
1071b8851fccSafresh1(otherwise) is eligible for indexing by PAUSE, the Perl Authors Upload Server.
1072b8851fccSafresh1Note This only checks for valid C<package> declarations, and does not take any
1073b8851fccSafresh1ownership information into account.
1074b8851fccSafresh1
1075b8851fccSafresh1=head1 SUPPORT
1076b8851fccSafresh1
1077b8851fccSafresh1Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Module-Metadata>
1078b8851fccSafresh1(or L<bug-Module-Metadata@rt.cpan.org|mailto:bug-Module-Metadata@rt.cpan.org>).
1079b8851fccSafresh1
1080b8851fccSafresh1There is also a mailing list available for users of this distribution, at
1081b8851fccSafresh1L<http://lists.perl.org/list/cpan-workers.html>.
1082b8851fccSafresh1
1083b8851fccSafresh1There is also an irc channel available for users of this distribution, at
10849f11ffb7Safresh1L<C<#toolchain> on C<irc.perl.org>|irc://irc.perl.org/#toolchain>.
1085898184e3Ssthen
1086898184e3Ssthen=head1 AUTHOR
1087898184e3Ssthen
1088898184e3SsthenOriginal code from Module::Build::ModuleInfo by Ken Williams
1089898184e3Ssthen<kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
1090898184e3Ssthen
1091898184e3SsthenReleased as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
1092898184e3Ssthenassistance from David Golden (xdg) <dagolden@cpan.org>.
1093898184e3Ssthen
1094b8851fccSafresh1=head1 CONTRIBUTORS
1095b8851fccSafresh1
1096*3d61058aSafresh1=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
1097b8851fccSafresh1
1098b8851fccSafresh1=over 4
1099b8851fccSafresh1
1100b8851fccSafresh1=item *
1101b8851fccSafresh1
1102b8851fccSafresh1Karen Etheridge <ether@cpan.org>
1103b8851fccSafresh1
1104b8851fccSafresh1=item *
1105b8851fccSafresh1
1106b8851fccSafresh1David Golden <dagolden@cpan.org>
1107b8851fccSafresh1
1108b8851fccSafresh1=item *
1109b8851fccSafresh1
1110b8851fccSafresh1Vincent Pit <perl@profvince.com>
1111b8851fccSafresh1
1112b8851fccSafresh1=item *
1113b8851fccSafresh1
1114b8851fccSafresh1Matt S Trout <mst@shadowcat.co.uk>
1115b8851fccSafresh1
1116b8851fccSafresh1=item *
1117b8851fccSafresh1
1118b8851fccSafresh1Chris Nehren <apeiron@cpan.org>
1119b8851fccSafresh1
1120b8851fccSafresh1=item *
1121b8851fccSafresh1
1122*3d61058aSafresh1Graham Knop <haarg@haarg.org>
1123b8851fccSafresh1
1124b8851fccSafresh1=item *
1125b8851fccSafresh1
1126b8851fccSafresh1Olivier Mengué <dolmen@cpan.org>
1127b8851fccSafresh1
1128b8851fccSafresh1=item *
1129b8851fccSafresh1
1130*3d61058aSafresh1Tomas Doran <bobtfish@bobtfish.net>
113156d68f1eSafresh1
113256d68f1eSafresh1=item *
113356d68f1eSafresh1
1134b46d8ef2Safresh1Christian Walde <walde.christian@googlemail.com>
1135b46d8ef2Safresh1
1136b46d8ef2Safresh1=item *
1137b46d8ef2Safresh1
1138b8851fccSafresh1Craig A. Berry <cberry@cpan.org>
1139b8851fccSafresh1
1140b8851fccSafresh1=item *
1141b8851fccSafresh1
1142*3d61058aSafresh1Tatsuhiko Miyagawa <miyagawa@bulknews.net>
1143*3d61058aSafresh1
1144*3d61058aSafresh1=item *
1145*3d61058aSafresh1
1146*3d61058aSafresh1tokuhirom <tokuhirom@gmail.com>
1147*3d61058aSafresh1
1148*3d61058aSafresh1=item *
1149*3d61058aSafresh1
1150*3d61058aSafresh1Chris 'BinGOs' Williams <chris@bingosnet.co.uk>
11519f11ffb7Safresh1
11529f11ffb7Safresh1=item *
11539f11ffb7Safresh1
1154b8851fccSafresh1David Mitchell <davem@iabyn.com>
1155b8851fccSafresh1
1156b8851fccSafresh1=item *
1157b8851fccSafresh1
1158b8851fccSafresh1David Steinbrunner <dsteinbrunner@pobox.com>
1159b8851fccSafresh1
1160b8851fccSafresh1=item *
1161b8851fccSafresh1
1162b8851fccSafresh1Edward Zborowski <ed@rubensteintech.com>
1163b8851fccSafresh1
1164b8851fccSafresh1=item *
1165b8851fccSafresh1
1166b8851fccSafresh1Gareth Harper <gareth@broadbean.com>
1167b8851fccSafresh1
1168b8851fccSafresh1=item *
1169b8851fccSafresh1
1170b8851fccSafresh1James Raspass <jraspass@gmail.com>
1171b8851fccSafresh1
1172b8851fccSafresh1=item *
1173b8851fccSafresh1
1174*3d61058aSafresh1Jerry D. Hedden <jdhedden@cpan.org>
1175b8851fccSafresh1
1176b8851fccSafresh1=item *
1177b8851fccSafresh1
11789f11ffb7Safresh1Josh Jore <jjore@cpan.org>
1179b8851fccSafresh1
1180b46d8ef2Safresh1=item *
1181b46d8ef2Safresh1
1182b46d8ef2Safresh1Kent Fredric <kentnl@cpan.org>
1183b46d8ef2Safresh1
1184*3d61058aSafresh1=item *
1185*3d61058aSafresh1
1186*3d61058aSafresh1Leon Timmermans <fawaka@gmail.com>
1187*3d61058aSafresh1
1188*3d61058aSafresh1=item *
1189*3d61058aSafresh1
1190*3d61058aSafresh1Peter Rabbitson <ribasushi@cpan.org>
1191*3d61058aSafresh1
1192*3d61058aSafresh1=item *
1193*3d61058aSafresh1
1194*3d61058aSafresh1Steve Hay <steve.m.hay@googlemail.com>
1195*3d61058aSafresh1
1196b8851fccSafresh1=back
1197b8851fccSafresh1
119891f110e0Safresh1=head1 COPYRIGHT & LICENSE
1199898184e3Ssthen
1200898184e3SsthenOriginal code Copyright (c) 2001-2011 Ken Williams.
1201898184e3SsthenAdditional code Copyright (c) 2010-2011 Matt Trout and David Golden.
1202898184e3SsthenAll rights reserved.
1203898184e3Ssthen
1204898184e3SsthenThis library is free software; you can redistribute it and/or
1205898184e3Ssthenmodify it under the same terms as Perl itself.
1206898184e3Ssthen
1207898184e3Ssthen=cut
1208