Add Module::Metadata as a dual-life core module
authorDavid Golden <dagolden@cpan.org>
Thu, 6 Jan 2011 03:47:41 +0000 (22:47 -0500)
committerDavid Golden <dagolden@cpan.org>
Fri, 7 Jan 2011 02:09:48 +0000 (21:09 -0500)
This commit adds Module::Metadata 1.000002 as a dual-life module.  It
gathers package and POD information from Perl module files.  It is a
standalone module based on Module::Build::ModuleInfo for use by other
module installation toolchain components.  Module::Build::ModuleInfo
has been deprecated in favor of this module instead.

MANIFEST
Porting/Maintainers.pl
cpan/Module-Metadata/lib/Module/Metadata.pm [new file with mode: 0644]
cpan/Module-Metadata/t/lib/DistGen.pm [new file with mode: 0644]
cpan/Module-Metadata/t/lib/MBTest.pm [new file with mode: 0644]
cpan/Module-Metadata/t/lib/Tie/CPHash.pm [new file with mode: 0644]
cpan/Module-Metadata/t/metadata.t [new file with mode: 0644]
lib/.gitignore
pod/perldelta.pod

index ba563e6..26ecda1 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1529,6 +1529,11 @@ cpan/Module-Load/t/to_load/LoadMe.pl             Module::Load tests
 cpan/Module-Load/t/to_load/Must/Be/Loaded.pm   Module::Load tests
 cpan/Module-Load/t/to_load/TestModule.pm       Module::Load tests
 cpan/Module-Load/t/to_load/ToBeLoaded          Module::Load tests
+cpan/Module-Metadata/lib/Module/Metadata.pm
+cpan/Module-Metadata/t/lib/DistGen.pm
+cpan/Module-Metadata/t/lib/MBTest.pm
+cpan/Module-Metadata/t/lib/Tie/CPHash.pm
+cpan/Module-Metadata/t/metadata.t
 cpan/Module-Pluggable/lib/Devel/InnerPackage.pm                Find inner packages
 cpan/Module-Pluggable/lib/Module/Pluggable/Object.pm   Module::Pluggable
 cpan/Module-Pluggable/lib/Module/Pluggable.pm          Module::Pluggable
index dcb1ad2..aa101a7 100755 (executable)
@@ -1046,6 +1046,15 @@ use File::Glob qw(:case);
        'UPSTREAM'      => 'cpan',
        },
 
+    'Module::Metadata' =>
+       {
+       'MAINTAINER'    => 'dagolden',
+       'DISTRIBUTION'  => 'DAGOLDEN/Module-Metadata-1.000002.tar.gz',
+       'FILES'         => q[cpan/Module-Metadata],
+       'EXCLUDED'      => [ ],
+       'UPSTREAM'      => 'cpan',
+       },
+
     'Module::Pluggable' =>
        {
        'MAINTAINER'    => 'simonw',
diff --git a/cpan/Module-Metadata/lib/Module/Metadata.pm b/cpan/Module-Metadata/lib/Module/Metadata.pm
new file mode 100644 (file)
index 0000000..6541f1e
--- /dev/null
@@ -0,0 +1,760 @@
+# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
+# vim:ts=8:sw=2:et:sta:sts=2
+package Module::Metadata;
+
+# stolen from Module::Build::Version and ::Base - this is perl licensed code,
+# copyright them.
+
+# This module provides routines to gather information about
+# perl modules (assuming this may be expanded in the distant
+# parrot future to look at other types of modules).
+
+use strict;
+use vars qw($VERSION);
+$VERSION = '1.000002';
+$VERSION = eval $VERSION;
+
+use File::Spec;
+use IO::File;
+use version 0.87;
+BEGIN {
+  if ($INC{'Log/Contextual.pm'}) {
+    Log::Contextual->import('log_info');
+  } else {
+    *log_info = sub (&) { warn $_[0]->() };
+  }
+}
+use File::Find qw(find);
+
+my $V_NUM_REGEXP = qr{v?[0-9._]+};  # crudely, a v-string or decimal
+
+my $PKG_REGEXP  = qr{   # match a package declaration
+  ^[\s\{;]*             # intro chars on a line
+  package               # the word 'package'
+  \s+                   # whitespace
+  ([\w:]+)              # a package name
+  \s*                   # optional whitespace
+  ($V_NUM_REGEXP)?        # optional version number
+  \s*                   # optional whitesapce
+  ;                     # semicolon line terminator
+}x;
+
+my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
+  ([\$*])         # sigil - $ or *
+  (
+    (             # optional leading package name
+      (?:::|\')?  # possibly starting like just :: (�  la $::VERSION)
+      (?:\w+(?:::|\'))*  # Foo::Bar:: ...
+    )?
+    VERSION
+  )\b
+}x;
+
+my $VERS_REGEXP = qr{ # match a VERSION definition
+  (?:
+    \(\s*$VARNAME_REGEXP\s*\) # with parens
+  |
+    $VARNAME_REGEXP           # without parens
+  )
+  \s*
+  =[^=~]  # = but not ==, nor =~
+}x;
+
+
+sub new_from_file {
+  my $class    = shift;
+  my $filename = File::Spec->rel2abs( shift );
+
+  return undef unless defined( $filename ) && -f $filename;
+  return $class->_init(undef, $filename, @_);
+}
+
+sub new_from_module {
+  my $class   = shift;
+  my $module  = shift;
+  my %props   = @_;
+
+  $props{inc} ||= \@INC;
+  my $filename = $class->find_module_by_name( $module, $props{inc} );
+  return undef unless defined( $filename ) && -f $filename;
+  return $class->_init($module, $filename, %props);
+}
+
+{
+  
+  my $compare_versions = sub {
+    my ($v1, $op, $v2) = @_;
+    $v1 = version->new($v1)
+      unless UNIVERSAL::isa($v1,'version');
+  
+    my $eval_str = "\$v1 $op \$v2";
+    my $result   = eval $eval_str;
+    log_info { "error comparing versions: '$eval_str' $@" } if $@;
+  
+    return $result;
+  };
+
+  my $normalize_version = sub {
+    my ($version) = @_;
+    if ( $version =~ /[=<>!,]/ ) { # logic, not just version
+      # take as is without modification
+    }
+    elsif ( ref $version eq 'version' ) { # version objects
+      $version = $version->is_qv ? $version->normal : $version->stringify;
+    }
+    elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
+      # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
+      $version = "v$version";
+    }
+    else {
+      # leave alone
+    }
+    return $version;
+  };
+
+  # separate out some of the conflict resolution logic
+
+  my $resolve_module_versions = sub {
+    my $packages = shift;
+  
+    my( $file, $version );
+    my $err = '';
+      foreach my $p ( @$packages ) {
+        if ( defined( $p->{version} ) ) {
+       if ( defined( $version ) ) {
+         if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
+           $err .= "  $p->{file} ($p->{version})\n";
+         } else {
+           # same version declared multiple times, ignore
+         }
+       } else {
+         $file    = $p->{file};
+         $version = $p->{version};
+       }
+        }
+        $file ||= $p->{file} if defined( $p->{file} );
+      }
+  
+    if ( $err ) {
+      $err = "  $file ($version)\n" . $err;
+    }
+  
+    my %result = (
+      file    => $file,
+      version => $version,
+      err     => $err
+    );
+  
+    return \%result;
+  };
+
+  sub package_versions_from_directory {
+    my ( $class, $dir, $files ) = @_;
+
+    my @files;
+
+    if ( $files ) {
+      @files = @$files;
+    } else {
+      find( {
+        wanted => sub {
+          push @files, $_ if -f $_ && /\.pm$/;
+        },
+        no_chdir => 1,
+      }, $dir );
+    }
+
+    # First, we enumerate all packages & versions,
+    # separating into primary & alternative candidates
+    my( %prime, %alt );
+    foreach my $file (@files) {
+      my $mapped_filename = File::Spec->abs2rel( $file, $dir );
+      my @path = split( /\//, $mapped_filename );
+      (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
+  
+      my $pm_info = $class->new_from_file( $file );
+  
+      foreach my $package ( $pm_info->packages_inside ) {
+        next if $package eq 'main';  # main can appear numerous times, ignore
+        next if $package eq 'DB';    # special debugging package, ignore
+        next if grep /^_/, split( /::/, $package ); # private package, ignore
+  
+        my $version = $pm_info->version( $package );
+  
+        if ( $package eq $prime_package ) {
+          if ( exists( $prime{$package} ) ) {
+            # M::B::ModuleInfo will handle this conflict
+            die "Unexpected conflict in '$package'; multiple versions found.\n";
+          } else {
+            $prime{$package}{file} = $mapped_filename;
+            $prime{$package}{version} = $version if defined( $version );
+          }
+        } else {
+          push( @{$alt{$package}}, {
+                                    file    => $mapped_filename,
+                                    version => $version,
+                                   } );
+        }
+      }
+    }
+  
+    # Then we iterate over all the packages found above, identifying conflicts
+    # and selecting the "best" candidate for recording the file & version
+    # for each package.
+    foreach my $package ( keys( %alt ) ) {
+      my $result = $resolve_module_versions->( $alt{$package} );
+  
+      if ( exists( $prime{$package} ) ) { # primary package selected
+  
+        if ( $result->{err} ) {
+       # Use the selected primary package, but there are conflicting
+       # errors among multiple alternative packages that need to be
+       # reported
+          log_info {
+           "Found conflicting versions for package '$package'\n" .
+           "  $prime{$package}{file} ($prime{$package}{version})\n" .
+           $result->{err}
+          };
+  
+        } elsif ( defined( $result->{version} ) ) {
+       # There is a primary package selected, and exactly one
+       # alternative package
+  
+       if ( exists( $prime{$package}{version} ) &&
+            defined( $prime{$package}{version} ) ) {
+         # Unless the version of the primary package agrees with the
+         # version of the alternative package, report a conflict
+         if ( $compare_versions->(
+                 $prime{$package}{version}, '!=', $result->{version}
+               )
+             ) {
+
+            log_info {
+              "Found conflicting versions for package '$package'\n" .
+             "  $prime{$package}{file} ($prime{$package}{version})\n" .
+             "  $result->{file} ($result->{version})\n"
+            };
+         }
+  
+       } else {
+         # The prime package selected has no version so, we choose to
+         # use any alternative package that does have a version
+         $prime{$package}{file}    = $result->{file};
+         $prime{$package}{version} = $result->{version};
+       }
+  
+        } else {
+       # no alt package found with a version, but we have a prime
+       # package so we use it whether it has a version or not
+        }
+  
+      } else { # No primary package was selected, use the best alternative
+  
+        if ( $result->{err} ) {
+          log_info {
+            "Found conflicting versions for package '$package'\n" .
+           $result->{err}
+          };
+        }
+  
+        # Despite possible conflicting versions, we choose to record
+        # something rather than nothing
+        $prime{$package}{file}    = $result->{file};
+        $prime{$package}{version} = $result->{version}
+         if defined( $result->{version} );
+      }
+    }
+  
+    # Normalize versions.  Can't use exists() here because of bug in YAML::Node.
+    # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
+    for (grep defined $_->{version}, values %prime) {
+      $_->{version} = $normalize_version->( $_->{version} );
+    }
+  
+    return \%prime;
+  }
+} 
+  
+
+sub _init {
+  my $class    = shift;
+  my $module   = shift;
+  my $filename = shift;
+  my %props = @_;
+
+  my( %valid_props, @valid_props );
+  @valid_props = qw( collect_pod inc );
+  @valid_props{@valid_props} = delete( @props{@valid_props} );
+  warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
+
+  my %data = (
+    module       => $module,
+    filename     => $filename,
+    version      => undef,
+    packages     => [],
+    versions     => {},
+    pod          => {},
+    pod_headings => [],
+    collect_pod  => 0,
+
+    %valid_props,
+  );
+
+  my $self = bless(\%data, $class);
+
+  $self->_parse_file();
+
+  unless($self->{module} and length($self->{module})) {
+    my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
+    if($f =~ /\.pm$/) {
+      $f =~ s/\..+$//;
+      my @candidates = grep /$f$/, @{$self->{packages}};
+      $self->{module} = shift(@candidates); # punt
+    }
+    else {
+      if(grep /main/, @{$self->{packages}}) {
+        $self->{module} = 'main';
+      }
+      else {
+        $self->{module} = $self->{packages}[0] || '';
+      }
+    }
+  }
+
+  $self->{version} = $self->{versions}{$self->{module}}
+      if defined( $self->{module} );
+
+  return $self;
+}
+
+# class method
+sub _do_find_module {
+  my $class   = shift;
+  my $module  = shift || die 'find_module_by_name() requires a package name';
+  my $dirs    = shift || \@INC;
+
+  my $file = File::Spec->catfile(split( /::/, $module));
+  foreach my $dir ( @$dirs ) {
+    my $testfile = File::Spec->catfile($dir, $file);
+    return [ File::Spec->rel2abs( $testfile ), $dir ]
+       if -e $testfile and !-d _;  # For stuff like ExtUtils::xsubpp
+    return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
+       if -e "$testfile.pm";
+  }
+  return;
+}
+
+# class method
+sub find_module_by_name {
+  my $found = shift()->_do_find_module(@_) or return;
+  return $found->[0];
+}
+
+# class method
+sub find_module_dir_by_name {
+  my $found = shift()->_do_find_module(@_) or return;
+  return $found->[1];
+}
+
+
+# given a line of perl code, attempt to parse it if it looks like a
+# $VERSION assignment, returning sigil, full name, & package name
+sub _parse_version_expression {
+  my $self = shift;
+  my $line = shift;
+
+  my( $sig, $var, $pkg );
+  if ( $line =~ $VERS_REGEXP ) {
+    ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
+    if ( $pkg ) {
+      $pkg = ($pkg eq '::') ? 'main' : $pkg;
+      $pkg =~ s/::$//;
+    }
+  }
+
+  return ( $sig, $var, $pkg );
+}
+
+sub _parse_file {
+  my $self = shift;
+
+  my $filename = $self->{filename};
+  my $fh = IO::File->new( $filename )
+    or die( "Can't open '$filename': $!" );
+
+  $self->_parse_fh($fh);
+}
+
+sub _parse_fh {
+  my ($self, $fh) = @_;
+
+  my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
+  my( @pkgs, %vers, %pod, @pod );
+  my $pkg = 'main';
+  my $pod_sect = '';
+  my $pod_data = '';
+
+  while (defined( my $line = <$fh> )) {
+    my $line_num = $.;
+
+    chomp( $line );
+    next if $line =~ /^\s*#/;
+
+    $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
+
+    # Would be nice if we could also check $in_string or something too
+    last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
+
+    if ( $in_pod || $line =~ /^=cut/ ) {
+
+      if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
+       push( @pod, $1 );
+       if ( $self->{collect_pod} && length( $pod_data ) ) {
+          $pod{$pod_sect} = $pod_data;
+          $pod_data = '';
+        }
+       $pod_sect = $1;
+
+
+      } elsif ( $self->{collect_pod} ) {
+       $pod_data .= "$line\n";
+
+      }
+
+    } else {
+
+      $pod_sect = '';
+      $pod_data = '';
+
+      # parse $line to see if it's a $VERSION declaration
+      my( $vers_sig, $vers_fullname, $vers_pkg ) =
+         $self->_parse_version_expression( $line );
+
+      if ( $line =~ $PKG_REGEXP ) {
+        $pkg = $1;
+        push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
+        $vers{$pkg} = (defined $2 ? $2 : undef)  unless exists( $vers{$pkg} );
+        $need_vers = defined $2 ? 0 : 1;
+
+      # VERSION defined with full package spec, i.e. $Module::VERSION
+      } elsif ( $vers_fullname && $vers_pkg ) {
+       push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
+       $need_vers = 0 if $vers_pkg eq $pkg;
+
+       unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
+         $vers{$vers_pkg} =
+           $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
+       } else {
+         # Warn unless the user is using the "$VERSION = eval
+         # $VERSION" idiom (though there are probably other idioms
+         # that we should watch out for...)
+         warn <<"EOM" unless $line =~ /=\s*eval/;
+Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
+ignoring subsequent declaration on line $line_num.
+EOM
+       }
+
+      # first non-comment line in undeclared package main is VERSION
+      } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
+       $need_vers = 0;
+       my $v =
+         $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
+       $vers{$pkg} = $v;
+       push( @pkgs, 'main' );
+
+      # first non-comment line in undeclared package defines package main
+      } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
+       $need_vers = 1;
+       $vers{main} = '';
+       push( @pkgs, 'main' );
+
+      # only keep if this is the first $VERSION seen
+      } elsif ( $vers_fullname && $need_vers ) {
+       $need_vers = 0;
+       my $v =
+         $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
+
+
+       unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
+         $vers{$pkg} = $v;
+       } else {
+         warn <<"EOM";
+Package '$pkg' already declared with version '$vers{$pkg}'
+ignoring new version '$v' on line $line_num.
+EOM
+       }
+
+      }
+
+    }
+
+  }
+
+  if ( $self->{collect_pod} && length($pod_data) ) {
+    $pod{$pod_sect} = $pod_data;
+  }
+
+  $self->{versions} = \%vers;
+  $self->{packages} = \@pkgs;
+  $self->{pod} = \%pod;
+  $self->{pod_headings} = \@pod;
+}
+
+{
+my $pn = 0;
+sub _evaluate_version_line {
+  my $self = shift;
+  my( $sigil, $var, $line ) = @_;
+
+  # Some of this code came from the ExtUtils:: hierarchy.
+
+  # We compile into $vsub because 'use version' would cause
+  # compiletime/runtime issues with local()
+  my $vsub;
+  $pn++; # everybody gets their own package
+  my $eval = qq{BEGIN { q#  Hide from _packages_inside()
+    #; package Module::Metadata::_version::p$pn;
+    use version;
+    no strict;
+
+    local $sigil$var;
+    \$$var=undef;
+      \$vsub = sub {
+        $line;
+        \$$var
+      };
+  }};
+
+  local $^W;
+  # Try to get the $VERSION
+  eval $eval;
+  # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
+  # installed, so we need to hunt in ./lib for it
+  if ( $@ =~ /Can't locate/ && -d 'lib' ) {
+    local @INC = ('lib',@INC);
+    eval $eval;
+  }
+  warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
+    if $@;
+  (ref($vsub) eq 'CODE') or
+    die "failed to build version sub for $self->{filename}";
+  my $result = eval { $vsub->() };
+  die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
+    if $@;
+
+  # Upgrade it into a version object
+  my $version = eval { _dwim_version($result) };
+
+  die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
+    unless defined $version; # "0" is OK!
+
+  return $version;
+}
+}
+
+# Try to DWIM when things fail the lax version test in obvious ways
+{
+  my @version_prep = (
+    # Best case, it just works
+    sub { return shift },
+
+    # If we still don't have a version, try stripping any
+    # trailing junk that is prohibited by lax rules
+    sub {
+      my $v = shift;
+      $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
+      return $v;
+    },
+
+    # Activestate apparently creates custom versions like '1.23_45_01', which
+    # cause version.pm to think it's an invalid alpha.  So check for that
+    # and strip them
+    sub {
+      my $v = shift;
+      my $num_dots = () = $v =~ m{(\.)}g;
+      my $num_unders = () = $v =~ m{(_)}g;
+      my $leading_v = substr($v,0,1) eq 'v';
+      if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
+        $v =~ s{_}{}g;
+        $num_unders = () = $v =~ m{(_)}g;
+      }
+      return $v;
+    },
+
+    # Worst case, try numifying it like we would have before version objects
+    sub {
+      my $v = shift;
+      no warnings 'numeric';
+      return 0 + $v;
+    },
+
+  );
+
+  sub _dwim_version {
+    my ($result) = shift;
+
+    return $result if ref($result) eq 'version';
+
+    my ($version, $error);
+    for my $f (@version_prep) {
+      $result = $f->($result);
+      $version = eval { version->new($result) };
+      $error ||= $@ if $@; # capture first failure
+      last if defined $version;
+    }
+
+    die $error unless defined $version;
+
+    return $version;
+  }
+}
+
+############################################################
+
+# accessors
+sub name            { $_[0]->{module}           }
+
+sub filename        { $_[0]->{filename}         }
+sub packages_inside { @{$_[0]->{packages}}      }
+sub pod_inside      { @{$_[0]->{pod_headings}}  }
+sub contains_pod    { $#{$_[0]->{pod_headings}} }
+
+sub version {
+    my $self = shift;
+    my $mod  = shift || $self->{module};
+    my $vers;
+    if ( defined( $mod ) && length( $mod ) &&
+        exists( $self->{versions}{$mod} ) ) {
+       return $self->{versions}{$mod};
+    } else {
+       return undef;
+    }
+}
+
+sub pod {
+    my $self = shift;
+    my $sect = shift;
+    if ( defined( $sect ) && length( $sect ) &&
+        exists( $self->{pod}{$sect} ) ) {
+       return $self->{pod}{$sect};
+    } else {
+       return undef;
+    }
+}
+
+1;
+
+=head1 NAME
+
+Module::Metadata - Gather package and POD information from perl module files
+
+=head1 DESCRIPTION
+
+=over 4
+
+=item new_from_file($filename, collect_pod => 1)
+
+Construct a C<ModuleInfo> object given the path to a file. Takes an optional
+argument C<collect_pod> which is a boolean that determines whether
+POD data is collected and stored for reference. POD data is not
+collected by default. POD headings are always collected.
+
+=item new_from_module($module, collect_pod => 1, inc => \@dirs)
+
+Construct a C<ModuleInfo> object given a module or package name. In addition
+to accepting the C<collect_pod> argument as described above, this
+method accepts a C<inc> argument which is a reference to an array of
+of directories to search for the module. If none are given, the
+default is @INC.
+
+=item name()
+
+Returns the name of the package represented by this module. If there
+are more than one packages, it makes a best guess based on the
+filename. If it's a script (i.e. not a *.pm) the package name is
+'main'.
+
+=item version($package)
+
+Returns the version as defined by the $VERSION variable for the
+package as returned by the C<name> method if no arguments are
+given. If given the name of a package it will attempt to return the
+version of that package if it is specified in the file.
+
+=item filename()
+
+Returns the absolute path to the file.
+
+=item packages_inside()
+
+Returns a list of packages.
+
+=item pod_inside()
+
+Returns a list of POD sections.
+
+=item contains_pod()
+
+Returns true if there is any POD in the file.
+
+=item pod($section)
+
+Returns the POD data in the given section.
+
+=item find_module_by_name($module, \@dirs)
+
+Returns the path to a module given the module or package name. A list
+of directories can be passed in as an optional parameter, otherwise
+@INC is searched.
+
+Can be called as either an object or a class method.
+
+=item find_module_dir_by_name($module, \@dirs)
+
+Returns the entry in C<@dirs> (or C<@INC> by default) that contains
+the module C<$module>. A list of directories can be passed in as an
+optional parameter, otherwise @INC is searched.
+
+Can be called as either an object or a class method.
+
+=item package_versions_from_directory($dir, \@files?)
+
+Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks
+for those files in C<$dir> - and reads each file for packages and versions,
+returning a hashref of the form:
+
+  {
+    'Package::Name' => {
+      version => '0.123',
+      file => 'Package/Name.pm'
+    },
+    'OtherPackage::Name' => ...
+  }
+
+=item log_info (internal)
+
+Used internally to perform logging; imported from Log::Contextual if
+Log::Contextual has already been loaded, otherwise simply calls warn.
+
+=back
+
+=head1 AUTHOR
+
+Ken Williams <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
+
+Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
+assistance from David Golden (xdg) <dagolden@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2001-2006 Ken Williams.  All rights reserved.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+perl(1), L<Module::Build::ModuleInfo>(3)
+
+=cut
+
diff --git a/cpan/Module-Metadata/t/lib/DistGen.pm b/cpan/Module-Metadata/t/lib/DistGen.pm
new file mode 100644 (file)
index 0000000..9fbd6d0
--- /dev/null
@@ -0,0 +1,845 @@
+package DistGen;
+
+use strict;
+
+use vars qw( $VERSION $VERBOSE @EXPORT_OK);
+
+$VERSION = '0.01';
+$VERBOSE = 0;
+
+use Carp;
+
+use MBTest ();
+use Cwd ();
+use File::Basename ();
+use File::Find ();
+use File::Path ();
+use File::Spec ();
+use IO::File ();
+use Tie::CPHash;
+use Data::Dumper;
+
+my $vms_mode;
+my $vms_lower_case;
+
+BEGIN {
+  $vms_mode = 0;
+  $vms_lower_case = 0;
+  if( $^O eq 'VMS' ) {
+    # For things like vmsify()
+    require VMS::Filespec;
+    VMS::Filespec->import;
+    $vms_mode = 1;
+    $vms_lower_case = 1;
+    my $vms_efs_case = 0;
+    my $unix_rpt = 0;
+    if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
+        $unix_rpt = VMS::Feature::current("filename_unix_report");
+        $vms_efs_case = VMS::Feature::current("efs_case_preserve");
+    } else {
+        my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
+        $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
+        my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || '';
+        $vms_efs_case = $efs_case =~ /^[ET1]/i;
+    }
+    $vms_mode = 0 if $unix_rpt;
+    $vms_lower_case = 0 if $vms_efs_case;
+  }
+}
+BEGIN {
+  require Exporter;
+  *{import} = \&Exporter::import;
+  @EXPORT_OK = qw(
+    undent
+  );
+}
+
+sub undent {
+  my ($string) = @_;
+
+  my ($space) = $string =~ m/^(\s+)/;
+  $string =~ s/^$space//gm;
+
+  return($string);
+}
+
+sub chdir_all ($) {
+  # OS/2 has "current directory per disk", undeletable;
+  # doing chdir() to another disk won't change cur-dir of initial disk...
+  chdir('/') if $^O eq 'os2';
+  chdir shift;
+}
+
+########################################################################
+
+END { chdir_all(MBTest->original_cwd); }
+
+sub new {
+  my $self = bless {}, shift;
+  $self->reset(@_);
+}
+
+sub reset {
+  my $self = shift;
+  my %options = @_;
+
+  $options{name} ||= 'Simple';
+  $options{dir} = File::Spec->rel2abs(
+    defined $options{dir} ? $options{dir} : MBTest->tmpdir
+  );
+
+  my %data = (
+    no_manifest   => 0,
+    xs            => 0,
+    inc           => 0,
+    %options,
+  );
+  %$self = %data;
+
+  tie %{$self->{filedata}}, 'Tie::CPHash';
+
+  tie %{$self->{pending}{change}}, 'Tie::CPHash';
+
+  # start with a fresh, empty directory
+  if ( -d $self->dirname ) {
+    warn "Warning: Removing existing directory '@{[$self->dirname]}'\n";
+    File::Path::rmtree( $self->dirname );
+  }
+  File::Path::mkpath( $self->dirname );
+
+  $self->_gen_default_filedata();
+
+  return $self;
+}
+
+sub remove {
+  my $self = shift;
+  $self->chdir_original if($self->did_chdir);
+  File::Path::rmtree( $self->dirname );
+  return $self;
+}
+
+sub revert {
+  my ($self, $file) = @_;
+  if ( defined $file ) {
+    delete $self->{filedata}{$file};
+    delete $self->{pending}{$_}{$file} for qw/change remove/;
+  }
+  else {
+    delete $self->{filedata}{$_} for keys %{ $self->{filedata} };
+    for my $pend ( qw/change remove/ ) {
+      delete $self->{pending}{$pend}{$_} for keys %{ $self->{pending}{$pend} };
+    }
+  }
+  $self->_gen_default_filedata;
+}
+
+sub _gen_default_filedata {
+  my $self = shift;
+
+  # TODO maybe a public method like this (but with a better name?)
+  my $add_unless = sub {
+    my $self = shift;
+    my ($member, $data) = @_;
+    $self->add_file($member, $data) unless($self->{filedata}{$member});
+  };
+
+  if ( ! $self->{inc} ) {
+    $self->$add_unless('Build.PL', undent(<<"      ---"));
+      use strict;
+      use Module::Build;
+
+      my \$builder = Module::Build->new(
+          module_name         => '$self->{name}',
+          license             => 'perl',
+      );
+
+      \$builder->create_build_script();
+      ---
+  }
+  else {
+    $self->$add_unless('Build.PL', undent(<<"      ---"));
+      use strict;
+      use inc::latest 'Module::Build';
+
+      my \$builder = Module::Build->new(
+          module_name         => '$self->{name}',
+          license             => 'perl',
+      );
+
+      \$builder->create_build_script();
+      ---
+  }
+
+  my $module_filename =
+    join( '/', ('lib', split(/::/, $self->{name})) ) . '.pm';
+
+  unless ( $self->{xs} ) {
+    $self->$add_unless($module_filename, undent(<<"      ---"));
+      package $self->{name};
+
+      use vars qw( \$VERSION );
+      \$VERSION = '0.01';
+
+      use strict;
+
+      1;
+
+      __END__
+
+      =head1 NAME
+
+      $self->{name} - Perl extension for blah blah blah
+
+      =head1 DESCRIPTION
+
+      Stub documentation for $self->{name}.
+
+      =head1 AUTHOR
+
+      A. U. Thor, a.u.thor\@a.galaxy.far.far.away
+
+      =cut
+      ---
+
+  $self->$add_unless('t/basic.t', undent(<<"    ---"));
+    use Test::More tests => 1;
+    use strict;
+
+    use $self->{name};
+    ok 1;
+    ---
+
+  } else {
+    $self->$add_unless($module_filename, undent(<<"      ---"));
+      package $self->{name};
+
+      \$VERSION = '0.01';
+
+      require Exporter;
+      require DynaLoader;
+
+      \@ISA = qw(Exporter DynaLoader);
+      \@EXPORT_OK = qw( okay );
+
+      bootstrap $self->{name} \$VERSION;
+
+      1;
+
+      __END__
+
+      =head1 NAME
+
+      $self->{name} - Perl extension for blah blah blah
+
+      =head1 DESCRIPTION
+
+      Stub documentation for $self->{name}.
+
+      =head1 AUTHOR
+
+      A. U. Thor, a.u.thor\@a.galaxy.far.far.away
+
+      =cut
+      ---
+
+    my $xs_filename =
+      join( '/', ('lib', split(/::/, $self->{name})) ) . '.xs';
+    $self->$add_unless($xs_filename, undent(<<"      ---"));
+      #include "EXTERN.h"
+      #include "perl.h"
+      #include "XSUB.h"
+
+      MODULE = $self->{name}         PACKAGE = $self->{name}
+
+      SV *
+      okay()
+          CODE:
+              RETVAL = newSVpv( "ok", 0 );
+          OUTPUT:
+              RETVAL
+
+      const char *
+      xs_version()
+          CODE:
+        RETVAL = XS_VERSION;
+          OUTPUT:
+        RETVAL
+
+      const char *
+      version()
+          CODE:
+        RETVAL = VERSION;
+          OUTPUT:
+        RETVAL
+      ---
+
+  # 5.6 is missing const char * in its typemap
+  $self->$add_unless('typemap', undent(<<"      ---"));
+      const char *\tT_PV
+      ---
+
+  $self->$add_unless('t/basic.t', undent(<<"    ---"));
+    use Test::More tests => 2;
+    use strict;
+
+    use $self->{name};
+    ok 1;
+
+    ok( $self->{name}::okay() eq 'ok' );
+    ---
+  }
+}
+
+sub _gen_manifest {
+  my $self     = shift;
+  my $manifest = shift;
+
+  my $fh = IO::File->new( ">$manifest" ) or do {
+    die "Can't write '$manifest'\n";
+  };
+
+  my @files = ( 'MANIFEST', keys %{$self->{filedata}} );
+  my $data = join( "\n", sort @files ) . "\n";
+  print $fh $data;
+  close( $fh );
+
+  $self->{filedata}{MANIFEST} = $data;
+  $self->{pending}{change}{MANIFEST} = 1;
+}
+
+sub name { shift()->{name} }
+
+sub dirname {
+  my $self = shift;
+  my $dist = $self->{distdir} || join( '-', split( /::/, $self->{name} ) );
+  return File::Spec->catdir( $self->{dir}, $dist );
+}
+
+sub _real_filename {
+  my $self = shift;
+  my $filename = shift;
+  return File::Spec->catfile( split( /\//, $filename ) );
+}
+
+sub regen {
+  my $self = shift;
+  my %opts = @_;
+
+  my $dist_dirname = $self->dirname;
+
+  if ( $opts{clean} ) {
+    $self->clean() if -d $dist_dirname;
+  } else {
+    # TODO: This might leave dangling directories; e.g. if the removed file
+    # is 'lib/Simple/Simon.pm', the directory 'lib/Simple' will be left
+    # even if there are no files left in it. However, clean() will remove it.
+    my @files = keys %{$self->{pending}{remove}};
+    foreach my $file ( @files ) {
+      my $real_filename = $self->_real_filename( $file );
+      my $fullname = File::Spec->catfile( $dist_dirname, $real_filename );
+      if ( -e $fullname ) {
+        1 while unlink( $fullname );
+      }
+      print "Unlinking pending file '$file'\n" if $VERBOSE;
+      delete( $self->{pending}{remove}{$file} );
+    }
+  }
+
+  foreach my $file ( keys( %{$self->{filedata}} ) ) {
+    my $real_filename = $self->_real_filename( $file );
+    my $fullname = File::Spec->catfile( $dist_dirname, $real_filename );
+
+    if  ( ! -e $fullname ||
+        (   -e $fullname && $self->{pending}{change}{$file} ) ) {
+
+      print "Changed file '$file'.\n" if $VERBOSE;
+
+      my $dirname = File::Basename::dirname( $fullname );
+      unless ( -d $dirname ) {
+        File::Path::mkpath( $dirname ) or do {
+          die "Can't create '$dirname'\n";
+        };
+      }
+
+      if ( -e $fullname ) {
+        1 while unlink( $fullname );
+      }
+
+      my $fh = IO::File->new(">$fullname") or do {
+        die "Can't write '$fullname'\n";
+      };
+      print $fh $self->{filedata}{$file};
+      close( $fh );
+    }
+
+    delete( $self->{pending}{change}{$file} );
+  }
+
+  my $manifest = File::Spec->catfile( $dist_dirname, 'MANIFEST' );
+  unless ( $self->{no_manifest} ) {
+    if ( -e $manifest ) {
+      1 while unlink( $manifest );
+    }
+    $self->_gen_manifest( $manifest );
+  }
+  return $self;
+}
+
+sub clean {
+  my $self = shift;
+
+  my $here  = Cwd::abs_path();
+  my $there = File::Spec->rel2abs( $self->dirname() );
+
+  if ( -d $there ) {
+    chdir( $there ) or die "Can't change directory to '$there'\n";
+  } else {
+    die "Distribution not found in '$there'\n";
+  }
+
+  my %names;
+  tie %names, 'Tie::CPHash';
+  foreach my $file ( keys %{$self->{filedata}} ) {
+    my $filename = $self->_real_filename( $file );
+    $filename = lc($filename) if $vms_lower_case;
+    my $dirname = File::Basename::dirname( $filename );
+
+    $names{$filename} = 0;
+
+    print "Splitting '$dirname'\n" if $VERBOSE;
+    my @dirs = File::Spec->splitdir( $dirname );
+    while ( @dirs ) {
+      my $dir = ( scalar(@dirs) == 1
+                  ? $dirname
+                  : File::Spec->catdir( @dirs ) );
+      if (length $dir) {
+        print "Setting directory name '$dir' in \%names\n" if $VERBOSE;
+        $names{$dir} = 0;
+      }
+      pop( @dirs );
+    }
+  }
+
+  File::Find::finddepth( sub {
+    my $name = File::Spec->canonpath( $File::Find::name );
+
+    if ($vms_mode) {
+        if ($name ne '.') {
+            $name =~ s/\.\z//;
+            $name = vmspath($name) if -d $name;
+        }
+    }
+    if ($^O eq 'VMS') {
+        $name = File::Spec->rel2abs($name) if $name eq File::Spec->curdir();
+    }
+
+    if ( not exists $names{$name} ) {
+      print "Removing '$name'\n" if $VERBOSE;
+      File::Path::rmtree( $_ );
+    }
+  }, ($^O eq 'VMS' ? './' : File::Spec->curdir) );
+
+  chdir_all( $here );
+  return $self;
+}
+
+sub add_file {
+  my $self = shift;
+  $self->change_file( @_ );
+}
+
+sub remove_file {
+  my $self = shift;
+  my $file = shift;
+  unless ( exists $self->{filedata}{$file} ) {
+    warn "Can't remove '$file': It does not exist.\n" if $VERBOSE;
+  }
+  delete( $self->{filedata}{$file} );
+  $self->{pending}{remove}{$file} = 1;
+  return $self;
+}
+
+sub change_build_pl {
+  my ($self, @opts) = @_;
+
+  my $opts = ref $opts[0] eq 'HASH' ? $opts[0] : { @opts };
+
+  local $Data::Dumper::Terse = 1;
+  (my $args = Dumper($opts)) =~ s/^\s*\{|\}\s*$//g;
+
+  $self->change_file( 'Build.PL', undent(<<"    ---") );
+    use strict;
+    use Module::Build;
+    my \$b = Module::Build->new(
+    # Some CPANPLUS::Dist::Build versions need to allow mismatches
+    # On logic: thanks to Module::Install, CPAN.pm must set both keys, but
+    # CPANPLUS sets only the one
+    allow_mb_mismatch => (
+      \$ENV{PERL5_CPANPLUS_IS_RUNNING} && ! \$ENV{PERL5_CPAN_IS_RUNNING} ? 1 : 0
+    ),
+    $args
+    );
+    \$b->create_build_script();
+    ---
+  return $self;
+}
+
+sub change_file {
+  my $self = shift;
+  my $file = shift;
+  my $data = shift;
+  $self->{filedata}{$file} = $data;
+  $self->{pending}{change}{$file} = 1;
+  return $self;
+}
+
+sub get_file {
+  my $self = shift;
+  my $file = shift;
+  exists($self->{filedata}{$file}) or croak("no such entry: '$file'");
+  return $self->{filedata}{$file};
+}
+
+sub chdir_in {
+  my $self = shift;
+  $self->{original_dir} ||= Cwd::cwd; # only once!
+  my $dir = $self->dirname;
+  chdir($dir) or die "Can't chdir to '$dir': $!";
+  return $self;
+}
+########################################################################
+
+sub did_chdir { exists shift()->{original_dir} }
+
+########################################################################
+
+sub chdir_original {
+  my $self = shift;
+
+  my $dir = delete $self->{original_dir};
+  chdir_all($dir) or die "Can't chdir to '$dir': $!";
+  return $self;
+}
+########################################################################
+
+sub new_from_context {
+  my ($self, @args) = @_;
+  require Module::Build;
+  return Module::Build->new_from_context( quiet => 1, @args );
+}
+
+sub run_build_pl {
+  my ($self, @args) = @_;
+  require Module::Build;
+  return Module::Build->run_perl_script('Build.PL', [], [@args])
+}
+
+sub run_build {
+  my ($self, @args) = @_;
+  require Module::Build;
+  my $build_script = $^O eq 'VMS' ? 'Build.com' : 'Build';
+  return Module::Build->run_perl_script($build_script, [], [@args])
+}
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+DistGen - Creates simple distributions for testing.
+
+=head1 SYNOPSIS
+
+  use DistGen;
+
+  # create distribution and prepare to test
+  my $dist = DistGen->new(name => 'Foo::Bar');
+  $dist->chdir_in;
+
+  # change distribution files
+  $dist->add_file('t/some_test.t', $contents);
+  $dist->change_file('MANIFEST.SKIP', $new_contents);
+  $dist->remove_file('t/some_test.t');
+  $dist->regen;
+
+  # undo changes and clean up extraneous files
+  $dist->revert;
+  $dist->clean;
+
+  # exercise the command-line interface
+  $dist->run_build_pl();
+  $dist->run_build('test');
+
+  # start over as a new distribution
+  $dist->reset( name => 'Foo::Bar', xs => 1 );
+  $dist->chdir_in;
+
+=head1 USAGE
+
+A DistGen object manages a set of files in a distribution directory.
+
+The C<new()> constructor initializes the object and creates an empty
+directory for the distribution. It does not create files or chdir into
+the directory.  The C<reset()> method re-initializes the object in a
+new directory with new parameters.  It also does not create files or change
+the current directory.
+
+Some methods only define the target state of the distribution.  They do B<not>
+make any changes to the filesystem:
+
+  add_file
+  change_file
+  change_build_pl
+  remove_file
+  revert
+
+Other methods then change the filesystem to match the target state of
+the distribution:
+
+  clean
+  regen
+  remove
+
+Other methods are provided for a convenience during testing. The
+most important is the one to enter the distribution directory:
+
+  chdir_in
+
+Additional methods portably encapsulate running Build.PL and Build:
+
+  run_build_pl
+  run_build
+
+=head1 API
+
+=head2 Constructors
+
+=head3 new()
+
+Create a new object and an empty directory to hold the distribution's files.
+If no C<dir> option is provided, it defaults to MBTest->tmpdir, which sets
+a different temp directory for Perl core testing and CPAN testing.
+
+The C<new> method does not write any files -- see L</regen()> below.
+
+  my $dist = DistGen->new(
+    name        => 'Foo::Bar',
+    dir         => MBTest->tmpdir,
+    xs          => 1,
+    no_manifest => 0,
+  );
+
+The parameters are as follows.
+
+=over
+
+=item name
+
+The name of the module this distribution represents. The default is
+'Simple'.  This should be a "Foo::Bar" (module) name, not a "Foo-Bar"
+dist name.
+
+=item dir
+
+The (parent) directory in which to create the distribution directory.  The
+distribution will be created under this according to C<distdir> parameter
+below.  Defaults to a temporary directory.
+
+  $dist = DistGen->new( dir => '/tmp/MB-test' );
+  $dist->regen;
+
+  # distribution files have been created in /tmp/MB-test/Simple
+
+=item distdir
+
+The name of the distribution directory to create.  Defaults to the dist form of
+C<name>, e.g. 'Foo-Bar' if C<name> is 'Foo::Bar'.
+
+=item xs
+
+If true, generates an XS based module.
+
+=item no_manifest
+
+If true, C<regen()> will not create a MANIFEST file.
+
+=back
+
+The following files are added as part of the default distribution:
+
+  Build.PL
+  lib/Simple.pm # based on name parameter
+  t/basic.t
+
+If an XS module is generated, Simple.pm and basic.t are different and
+the following files are also added:
+
+  typemap
+  lib/Simple.xs # based on name parameter
+
+=head3 reset()
+
+The C<reset> method re-initializes the object as if it were generated
+from a fresh call to C<new>.  It takes the same optional parameters as C<new>.
+
+  $dist->reset( name => 'Foo::Bar', xs => 0 );
+
+=head2 Adding and editing files
+
+Note that C<$filename> should always be specified with unix-style paths,
+and are relative to the distribution root directory, e.g. C<lib/Module.pm>.
+
+No changes are made to the filesystem until the distribution is regenerated.
+
+=head3 add_file()
+
+Add a $filename containing $content to the distribution.
+
+  $dist->add_file( $filename, $content );
+
+=head3 change_file()
+
+Changes the contents of $filename to $content. No action is performed
+until the distribution is regenerated.
+
+  $dist->change_file( $filename, $content );
+
+=head3 change_build_pl()
+
+A wrapper around change_file specifically for setting Build.PL.  Instead
+of file C<$content>, it takes a hash-ref of Module::Build constructor
+arguments:
+
+  $dist->change_build_pl(
+    {
+      module_name         => $dist->name,
+      dist_version        => '3.14159265',
+      license             => 'perl',
+      create_readme       => 1,
+    }
+  );
+
+=head3 get_file
+
+Retrieves the target contents of C<$filename>.
+
+  $content = $dist->get_file( $filename );
+
+=head3 remove_file()
+
+Removes C<$filename> from the distribution.
+
+  $dist->remove_file( $filename );
+
+=head3 revert()
+
+Returns the object to its initial state, or given a $filename it returns that
+file to its initial state if it is one of the built-in files.
+
+  $dist->revert;
+  $dist->revert($filename);
+
+=head2 Changing the distribution directory
+
+These methods immediately affect the filesystem.
+
+=head3 regen()
+
+Regenerate all missing or changed files.  Also deletes any files
+flagged for removal with remove_file().
+
+  $dist->regen(clean => 1);
+
+If the optional C<clean> argument is given, it also calls C<clean>.  These
+can also be chained like this, instead:
+
+  $dist->clean->regen;
+
+=head3 clean()
+
+Removes any files that are not part of the distribution.
+
+  $dist->clean;
+
+=head3 remove()
+
+Changes back to the original directory and removes the distribution
+directory (but not the temporary directory set during C<new()>).
+
+  $dist = DistGen->new->chdir->regen;
+  # ... do some testing ...
+
+  $dist->remove->chdir_in->regen;
+  # ... do more testing ...
+
+This is like a more aggressive form of C<clean>.  Generally, calling C<clean>
+and C<regen> should be sufficient.
+
+=head2 Changing directories
+
+=head3 chdir_in
+
+Change directory into the dist root.
+
+  $dist->chdir_in;
+
+=head3 chdir_original
+
+Returns to whatever directory you were in before chdir_in() (regardless
+of the cwd.)
+
+  $dist->chdir_original;
+
+=head2 Command-line helpers
+
+These use Module::Build->run_perl_script() to ensure that Build.PL or Build are
+run in a separate process using the current perl interpreter.  (Module::Build
+is loaded on demand).  They also ensure appropriate naming for operating
+systems that require a suffix for Build.
+
+=head3 run_build_pl
+
+Runs Build.PL using the current perl interpreter.  Any arguments are
+passed on the command line.
+
+  $dist->run_build_pl('--quiet');
+
+=head3 run_build
+
+Runs Build using the current perl interpreter.  Any arguments are
+passed on the command line.
+
+  $dist->run_build(qw/test --verbose/);
+
+=head2 Properties
+
+=head3 name()
+
+Returns the name of the distribution.
+
+  $dist->name: # e.g. Foo::Bar
+
+=head3 dirname()
+
+Returns the directory where the distribution is created.
+
+  $dist->dirname; # e.g. t/_tmp/Simple
+
+=head2 Functions
+
+=head3 undent()
+
+Removes leading whitespace from a multi-line string according to the
+amount of whitespace on the first line.
+
+  my $string = undent("  foo(\n    bar => 'baz'\n  )");
+  $string eq "foo(
+    bar => 'baz'
+  )";
+
+=cut
+
+# vim:ts=2:sw=2:et:sta
diff --git a/cpan/Module-Metadata/t/lib/MBTest.pm b/cpan/Module-Metadata/t/lib/MBTest.pm
new file mode 100644 (file)
index 0000000..005920f
--- /dev/null
@@ -0,0 +1,279 @@
+package MBTest;
+
+use strict;
+
+use IO::File ();
+use File::Spec;
+use File::Temp ();
+use File::Path ();
+
+
+# Setup the code to clean out %ENV
+BEGIN {
+    # Environment variables which might effect our testing
+    my @delete_env_keys = qw(
+        HOME
+        DEVEL_COVER_OPTIONS
+        MODULEBUILDRC
+        PERL_MB_OPT
+        HARNESS_TIMER
+        HARNESS_OPTIONS
+        HARNESS_VERBOSE
+        PREFIX
+        INSTALL_BASE
+        INSTALLDIRS
+    );
+
+    # Remember the ENV values because on VMS %ENV is global
+    # to the user, not the process.
+    my %restore_env_keys;
+
+    sub clean_env {
+        for my $key (@delete_env_keys) {
+            if( exists $ENV{$key} ) {
+                $restore_env_keys{$key} = delete $ENV{$key};
+            }
+            else {
+                delete $ENV{$key};
+            }
+        }
+    }
+
+    END {
+        while( my($key, $val) = each %restore_env_keys ) {
+            $ENV{$key} = $val;
+        }
+    }
+}
+
+
+BEGIN {
+  clean_env();
+
+  # In case the test wants to use our other bundled
+  # modules, make sure they can be loaded.
+  my $t_lib = File::Spec->catdir('t', 'bundled');
+  push @INC, $t_lib; # Let user's installed version override
+
+  if ($ENV{PERL_CORE}) {
+    # We change directories, so expand @INC and $^X to absolute paths
+    # Also add .
+    @INC = (map(File::Spec->rel2abs($_), @INC), ".");
+    $^X = File::Spec->rel2abs($^X);
+  }
+}
+
+use Exporter;
+use Test::More;
+use Config;
+use Cwd ();
+
+# We pass everything through to Test::More
+use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
+$VERSION = 0.01_01;
+@ISA = qw(Test::More); # Test::More isa Exporter
+@EXPORT = @Test::More::EXPORT;
+%EXPORT_TAGS = %Test::More::EXPORT_TAGS;
+
+# We have a few extra exports, but Test::More has a special import()
+# that won't take extra additions.
+my @extra_exports = qw(
+  stdout_of
+  stderr_of
+  stdout_stderr_of
+  slurp
+  find_in_path
+  check_compiler
+  have_module
+  blib_load
+  timed_out
+);
+push @EXPORT, @extra_exports;
+__PACKAGE__->export(scalar caller, @extra_exports);
+# XXX ^-- that should really happen in import()
+
+
+########################################################################
+
+# always return to the current directory
+{
+  my $cwd = File::Spec->rel2abs(Cwd::cwd);
+
+  sub original_cwd { return $cwd }
+
+  END {
+    # Go back to where you came from!
+    chdir $cwd or die "Couldn't chdir to $cwd";
+  }
+}
+########################################################################
+
+{ # backwards compatible temp filename recipe adapted from perlfaq
+  my $tmp_count = 0;
+  my $tmp_base_name = sprintf("MB-%d-%d", $$, time());
+  sub temp_file_name {
+    sprintf("%s-%04d", $tmp_base_name, ++$tmp_count)
+  }
+}
+########################################################################
+
+# Setup a temp directory
+sub tmpdir {
+  my ($self, @args) = @_;
+  my $dir = $ENV{PERL_CORE} ? MBTest->original_cwd : File::Spec->tmpdir;
+  return File::Temp::tempdir('MB-XXXXXXXX', CLEANUP => 1, DIR => $dir, @args);
+}
+
+BEGIN {
+  $ENV{HOME} = tmpdir; # don't want .modulebuildrc or other things interfering
+}
+
+sub save_handle {
+  my ($handle, $subr) = @_;
+  my $outfile = File::Spec->catfile(File::Spec->tmpdir, temp_file_name());
+
+  local *SAVEOUT;
+  open SAVEOUT, ">&" . fileno($handle)
+    or die "Can't save output handle: $!";
+  open $handle, "> $outfile" or die "Can't create $outfile: $!";
+
+  eval {$subr->()};
+  open $handle, ">&SAVEOUT" or die "Can't restore output: $!";
+
+  my $ret = slurp($outfile);
+  1 while unlink $outfile;
+  return $ret;
+}
+
+sub stdout_of { save_handle(\*STDOUT, @_) }
+sub stderr_of { save_handle(\*STDERR, @_) }
+sub stdout_stderr_of {
+  my $subr = shift;
+  my ($stdout, $stderr);
+  $stdout = stdout_of ( sub {
+      $stderr = stderr_of( $subr )
+  });
+  return wantarray ? ($stdout, $stderr) : $stdout . $stderr;
+}
+
+sub slurp {
+  my $fh = IO::File->new($_[0]) or die "Can't open $_[0]: $!";
+  local $/;
+  return scalar <$fh>;
+}
+
+# Some extensions we should know about if we're looking for executables
+sub exe_exts {
+
+  if ($^O eq 'MSWin32') {
+    return split($Config{path_sep}, $ENV{PATHEXT} || '.com;.exe;.bat');
+  }
+  if ($^O eq 'os2') {
+    return qw(.exe .com .pl .cmd .bat .sh .ksh);
+  }
+  return;
+}
+
+sub find_in_path {
+  my $thing = shift;
+
+  my @exe_ext = exe_exts();
+  if ( File::Spec->file_name_is_absolute( $thing ) ) {
+    foreach my $ext ( '', @exe_ext ) {
+      return "$thing$ext" if -e "$thing$ext";
+    }
+  }
+  else {
+    my @path = split $Config{path_sep}, $ENV{PATH};
+    foreach (@path) {
+      my $fullpath = File::Spec->catfile($_, $thing);
+      foreach my $ext ( '', @exe_ext ) {
+        return "$fullpath$ext" if -e "$fullpath$ext";
+      }
+    }
+  }
+  return;
+}
+
+sub check_compiler {
+  return (1,1) if $ENV{PERL_CORE};
+
+  local $SIG{__WARN__} = sub {};
+
+  blib_load('Module::Build');
+  my $mb = Module::Build->current;
+  $mb->verbose( 0 );
+
+  my $have_c_compiler;
+  stderr_of( sub {$have_c_compiler = $mb->have_c_compiler} );
+
+  # check noexec tmpdir
+  my $tmp_exec;
+  if ( $have_c_compiler ) {
+    my $dir = MBTest->tmpdir;
+    my $c_file = File::Spec->catfile($dir,'test.c');
+    open my $fh, ">", $c_file;
+    print {$fh} "int main() { return 0; }\n";
+    close $fh;
+    my $exe = $mb->cbuilder->link_executable(
+      objects => $mb->cbuilder->compile( source => $c_file )
+    );
+    $tmp_exec = 0 == system( $exe );
+  }
+  return ($have_c_compiler, $tmp_exec);
+}
+
+sub have_module {
+  my $module = shift;
+  return eval "require $module; 1";
+}
+
+sub blib_load {
+  # Load the given module and ensure it came from blib/, not the larger system
+  my $mod = shift;
+  have_module($mod) or die "Error loading $mod\: $@\n";
+
+  (my $path = $mod) =~ s{::}{/}g;
+  $path .= ".pm";
+  my ($pkg, $file, $line) = caller;
+  unless($ENV{PERL_CORE}) {
+    unless($INC{$path} =~ m/\bblib\b/) {
+      (my $load_from = $INC{$path}) =~ s{$path$}{};
+      die "$mod loaded from '$load_from'\nIt should have been loaded from blib.  \@INC contains:\n  ",
+      join("\n  ", @INC) . "\nFatal error occured in blib_load() at $file, line $line.\n";
+    }
+  }
+}
+
+sub timed_out {
+  my ($sub, $timeout) = @_;
+  return unless $sub;
+  $timeout ||= 60;
+
+  my $saw_alarm = 0;
+  eval {
+    local $SIG{ALRM} = sub { $saw_alarm++; die "alarm\n"; }; # NB: \n required
+    alarm $timeout;
+    $sub->();
+    alarm 0;
+  };
+  if ($@) {
+    die unless $@ eq "alarm\n";   # propagate unexpected errors
+  }
+  return $saw_alarm;
+}
+
+sub check_EUI {
+  my $timed_out;
+  stdout_stderr_of( sub {
+      $timed_out = timed_out( sub {
+          ExtUtils::Installed->new(extra_libs => [@INC])
+        }
+      );
+    }
+  );
+  return ! $timed_out;
+}
+
+1;
+# vim:ts=2:sw=2:et:sta
diff --git a/cpan/Module-Metadata/t/lib/Tie/CPHash.pm b/cpan/Module-Metadata/t/lib/Tie/CPHash.pm
new file mode 100644 (file)
index 0000000..b167622
--- /dev/null
@@ -0,0 +1,194 @@
+#---------------------------------------------------------------------
+package Tie::CPHash;
+#
+# Copyright 1997 Christopher J. Madsen
+#
+# Author: Christopher J. Madsen <cjm@pobox.com>
+# Created: 08 Nov 1997
+# $Revision$  $Date$
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the same terms as Perl itself.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either the
+# GNU General Public License or the Artistic License for more details.
+#
+# Case preserving but case insensitive hash
+#---------------------------------------------------------------------
+
+require 5.000;
+use strict;
+use vars qw(@ISA $VERSION);
+
+@ISA = qw();
+
+#=====================================================================
+# Package Global Variables:
+
+$VERSION = '1.02';
+
+#=====================================================================
+# Tied Methods:
+#---------------------------------------------------------------------
+# TIEHASH classname
+#      The method invoked by the command `tie %hash, classname'.
+#      Associates a new hash instance with the specified class.
+
+sub TIEHASH
+{
+    bless {}, $_[0];
+} # end TIEHASH
+
+#---------------------------------------------------------------------
+# STORE this, key, value
+#      Store datum *value* into *key* for the tied hash *this*.
+
+sub STORE
+{
+    $_[0]->{lc $_[1]} = [ $_[1], $_[2] ];
+} # end STORE
+
+#---------------------------------------------------------------------
+# FETCH this, key
+#      Retrieve the datum in *key* for the tied hash *this*.
+
+sub FETCH
+{
+    my $v = $_[0]->{lc $_[1]};
+    ($v ? $v->[1] : undef);
+} # end FETCH
+
+#---------------------------------------------------------------------
+# FIRSTKEY this
+#      Return the (key, value) pair for the first key in the hash.
+
+sub FIRSTKEY
+{
+    my $a = scalar keys %{$_[0]};
+    &NEXTKEY;
+} # end FIRSTKEY
+
+#---------------------------------------------------------------------
+# NEXTKEY this, lastkey
+#      Return the next (key, value) pair for the hash.
+
+sub NEXTKEY
+{
+    my $v = (each %{$_[0]})[1];
+    ($v ? $v->[0] : undef );
+} # end NEXTKEY
+
+#---------------------------------------------------------------------
+# SCALAR this
+#     Return bucket usage information for the hash (0 if empty).
+
+sub SCALAR
+{
+    scalar %{$_[0]};
+} # end SCALAR
+
+#---------------------------------------------------------------------
+# EXISTS this, key
+#     Verify that *key* exists with the tied hash *this*.
+
+sub EXISTS
+{
+    exists $_[0]->{lc $_[1]};
+} # end EXISTS
+
+#---------------------------------------------------------------------
+# DELETE this, key
+#     Delete the key *key* from the tied hash *this*.
+#     Returns the old value, or undef if it didn't exist.
+
+sub DELETE
+{
+    my $v = delete $_[0]->{lc $_[1]};
+    ($v ? $v->[1] : undef);
+} # end DELETE
+
+#---------------------------------------------------------------------
+# CLEAR this
+#     Clear all values from the tied hash *this*.
+
+sub CLEAR
+{
+    %{$_[0]} = ();
+} # end CLEAR
+
+#=====================================================================
+# Other Methods:
+#---------------------------------------------------------------------
+# Return the case of KEY.
+
+sub key
+{
+    my $v = $_[0]->{lc $_[1]};
+    ($v ? $v->[0] : undef);
+}
+
+#=====================================================================
+# Package Return Value:
+
+1;
+
+__END__
+
+=head1 NAME
+
+Tie::CPHash - Case preserving but case insensitive hash table
+
+=head1 SYNOPSIS
+
+    require Tie::CPHash;
+    tie %cphash, 'Tie::CPHash';
+
+    $cphash{'Hello World'} = 'Hi there!';
+    printf("The key `%s' was used to store `%s'.\n",
+           tied(%cphash)->key('HELLO WORLD'),
+           $cphash{'HELLO world'});
+
+=head1 DESCRIPTION
+
+The B<Tie::CPHash> module provides a hash table that is case
+preserving but case insensitive.  This means that
+
+    $cphash{KEY}    $cphash{key}
+    $cphash{Key}    $cphash{keY}
+
+all refer to the same entry.  Also, the hash remembers which form of
+the key was last used to store the entry.  The C<keys> and C<each>
+functions will return the key that was used to set the value.
+
+An example should make this clear:
+
+    tie %h, 'Tie::CPHash';
+    $h{Hello} = 'World';
+    print $h{HELLO};            # Prints 'World'
+    print keys(%h);             # Prints 'Hello'
+    $h{HELLO} = 'WORLD';
+    print $h{hello};            # Prints 'WORLD'
+    print keys(%h);             # Prints 'HELLO'
+
+The additional C<key> method lets you fetch the case of a specific key:
+
+    # When run after the previous example, this prints 'HELLO':
+    print tied(%h)->key('Hello');
+
+(The C<tied> function returns the object that C<%h> is tied to.)
+
+If you need a case insensitive hash, but don't need to preserve case,
+just use C<$hash{lc $key}> instead of C<$hash{$key}>.  This has a lot
+less overhead than B<Tie::CPHash>.
+
+=head1 AUTHOR
+
+Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt>
+
+=cut
+
+# Local Variables:
+# tmtrack-file-task: "Tie::CPHash.pm"
+# End:
diff --git a/cpan/Module-Metadata/t/metadata.t b/cpan/Module-Metadata/t/metadata.t
new file mode 100644 (file)
index 0000000..7f5cd92
--- /dev/null
@@ -0,0 +1,460 @@
+#!/usr/bin/perl -w
+# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
+# vim:ts=8:sw=2:et:sta:sts=2
+
+use strict;
+use lib 't/lib';
+use MBTest;
+
+# parse various module $VERSION lines
+# these will be reversed later to create %modules
+my @modules = (
+  '1.23' => <<'---', # declared & defined on same line with 'our'
+package Simple;
+our $VERSION = '1.23';
+---
+  '1.23' => <<'---', # declared & defined on separate lines with 'our'
+package Simple;
+our $VERSION;
+$VERSION = '1.23';
+---
+  '1.23' => <<'---', # use vars
+package Simple;
+use vars qw( $VERSION );
+$VERSION = '1.23';
+---
+  '1.23' => <<'---', # choose the right default package based on package/file name
+package Simple::_private;
+$VERSION = '0';
+package Simple;
+$VERSION = '1.23'; # this should be chosen for version
+---
+  '1.23' => <<'---', # just read the first $VERSION line
+package Simple;
+$VERSION = '1.23'; # we should see this line
+$VERSION = eval $VERSION; # and ignore this one
+---
+  '1.23' => <<'---', # just read the first $VERSION line in reopened package (1)
+package Simple;
+$VERSION = '1.23';
+package Error::Simple;
+$VERSION = '2.34';
+package Simple;
+---
+  '1.23' => <<'---', # just read the first $VERSION line in reopened package (2)
+package Simple;
+package Error::Simple;
+$VERSION = '2.34';
+package Simple;
+$VERSION = '1.23';
+---
+  '1.23' => <<'---', # mentions another module's $VERSION
+package Simple;
+$VERSION = '1.23';
+if ( $Other::VERSION ) {
+    # whatever
+}
+---
+  '1.23' => <<'---', # mentions another module's $VERSION in a different package
+package Simple;
+$VERSION = '1.23';
+package Simple2;
+if ( $Simple::VERSION ) {
+    # whatever
+}
+---
+  '1.23' => <<'---', # $VERSION checked only in assignments, not regexp ops
+package Simple;
+$VERSION = '1.23';
+if ( $VERSION =~ /1\.23/ ) {
+    # whatever
+}
+---
+  '1.23' => <<'---', # $VERSION checked only in assignments, not relational ops
+package Simple;
+$VERSION = '1.23';
+if ( $VERSION == 3.45 ) {
+    # whatever
+}
+---
+  '1.23' => <<'---', # $VERSION checked only in assignments, not relational ops
+package Simple;
+$VERSION = '1.23';
+package Simple2;
+if ( $Simple::VERSION == 3.45 ) {
+    # whatever
+}
+---
+  '1.23' => <<'---', # Fully qualified $VERSION declared in package
+package Simple;
+$Simple::VERSION = 1.23;
+---
+  '1.23' => <<'---', # Differentiate fully qualified $VERSION in a package
+package Simple;
+$Simple2::VERSION = '999';
+$Simple::VERSION = 1.23;
+---
+  '1.23' => <<'---', # Differentiate fully qualified $VERSION and unqualified
+package Simple;
+$Simple2::VERSION = '999';
+$VERSION = 1.23;
+---
+  '1.23' => <<'---', # $VERSION declared as package variable from within 'main' package
+$Simple::VERSION = '1.23';
+{
+  package Simple;
+  $x = $y, $cats = $dogs;
+}
+---
+  '1.23' => <<'---', # $VERSION wrapped in parens - space inside
+package Simple;
+( $VERSION ) = '1.23';
+---
+  '1.23' => <<'---', # $VERSION wrapped in parens - no space inside
+package Simple;
+($VERSION) = '1.23';
+---
+  '1.23' => <<'---', # $VERSION follows a spurious 'package' in a quoted construct
+package Simple;
+__PACKAGE__->mk_accessors(qw(
+    program socket proc
+    package filename line codeline subroutine finished));
+
+our $VERSION = "1.23";
+---
+  '1.23' => <<'---', # $VERSION using version.pm
+  package Simple;
+  use version; our $VERSION = version->new('1.23');
+---
+  '1.23' => <<'---', # $VERSION using version.pm and qv()
+  package Simple;
+  use version; our $VERSION = qv('1.230');
+---
+  '1.23' => <<'---', # Two version assignments, should ignore second one
+  $Simple::VERSION = '1.230';
+  $Simple::VERSION = eval $Simple::VERSION;
+---
+  '1.23' => <<'---', # declared & defined on same line with 'our'
+package Simple;
+our $VERSION = '1.23_00_00';
+---
+  '1.23' => <<'---', # package NAME VERSION
+  package Simple 1.23;
+---
+  '1.23_01' => <<'---', # package NAME VERSION
+  package Simple 1.23_01;
+---
+  'v1.2.3' => <<'---', # package NAME VERSION
+  package Simple v1.2.3;
+---
+  'v1.2_3' => <<'---', # package NAME VERSION
+  package Simple v1.2_3;
+---
+  '1.23' => <<'---', # trailing crud
+  package Simple;
+  our $VERSION;
+  $VERSION = '1.23-alpha';
+---
+  '1.23' => <<'---', # trailing crud
+  package Simple;
+  our $VERSION;
+  $VERSION = '1.23b';
+---
+  '1.234' => <<'---', # multi_underscore
+  package Simple;
+  our $VERSION;
+  $VERSION = '1.2_3_4';
+---
+  '0' => <<'---', # non-numeric
+  package Simple;
+  our $VERSION;
+  $VERSION = 'onetwothree';
+---
+);
+my %modules = reverse @modules;
+
+plan tests => 37 + 2 * keys( %modules );
+
+require_ok('Module::Metadata');
+
+my $tmp = MBTest->tmpdir;
+
+use DistGen;
+my $dist = DistGen->new( dir => $tmp );
+$dist->regen;
+
+$dist->chdir_in;
+
+#########################
+
+# class method C<find_module_by_name>
+my $module = Module::Metadata->find_module_by_name(
+               'Module::Metadata' );
+ok( -e $module, 'find_module_by_name() succeeds' );
+
+
+# fail on invalid module name
+my $pm_info = Module::Metadata->new_from_module(
+               'Foo::Bar', inc => [] );
+ok( !defined( $pm_info ), 'fail if can\'t find module by module name' );
+
+
+# fail on invalid filename
+my $file = File::Spec->catfile( 'Foo', 'Bar.pm' );
+$pm_info = Module::Metadata->new_from_file( $file, inc => [] );
+ok( !defined( $pm_info ), 'fail if can\'t find module by file name' );
+
+
+# construct from module filename
+$file = File::Spec->catfile( 'lib', split( /::/, $dist->name ) ) . '.pm';
+$pm_info = Module::Metadata->new_from_file( $file );
+ok( defined( $pm_info ), 'new_from_file() succeeds' );
+
+# construct from module name, using custom include path
+$pm_info = Module::Metadata->new_from_module(
+            $dist->name, inc => [ 'lib', @INC ] );
+ok( defined( $pm_info ), 'new_from_module() succeeds' );
+
+
+foreach my $module ( sort keys %modules ) {
+    my $expected = $modules{$module};
+ SKIP: {
+    skip( "No our() support until perl 5.6", 2 )
+        if $] < 5.006 && $module =~ /\bour\b/;
+    skip( "No package NAME VERSION support until perl 5.11.1", 2 )
+        if $] < 5.011001 && $module =~ /package\s+[\w\:\']+\s+v?[0-9._]+/;
+
+    $dist->change_file( 'lib/Simple.pm', $module );
+    $dist->regen;
+
+    my $warnings = '';
+    local $SIG{__WARN__} = sub { $warnings .= $_ for @_ };
+    my $pm_info = Module::Metadata->new_from_file( $file );
+
+    # Test::Builder will prematurely numify objects, so use this form
+    my $errs;
+    ok( $pm_info->version eq $expected,
+        "correct module version (expected '$expected')" )
+        or $errs++;
+    is( $warnings, '', 'no warnings from parsing' ) or $errs++;
+    diag "Got: '@{[$pm_info->version]}'\nModule contents:\n$module" if $errs;
+  }
+}
+
+# revert to pristine state
+$dist->regen( clean => 1 );
+
+# Find each package only once
+$dist->change_file( 'lib/Simple.pm', <<'---' );
+package Simple;
+$VERSION = '1.23';
+package Error::Simple;
+$VERSION = '2.34';
+package Simple;
+---
+
+$dist->regen;
+
+$pm_info = Module::Metadata->new_from_file( $file );
+
+my @packages = $pm_info->packages_inside;
+is( @packages, 2, 'record only one occurence of each package' );
+
+
+# Module 'Simple.pm' does not contain package 'Simple';
+# constructor should not complain, no default module name or version
+$dist->change_file( 'lib/Simple.pm', <<'---' );
+package Simple::Not;
+$VERSION = '1.23';
+---
+
+$dist->regen;
+$pm_info = Module::Metadata->new_from_file( $file );
+
+is( $pm_info->name, undef, 'no default package' );
+is( $pm_info->version, undef, 'no version w/o default package' );
+
+# Module 'Simple.pm' contains an alpha version
+# constructor should report first $VERSION found
+$dist->change_file( 'lib/Simple.pm', <<'---' );
+package Simple;
+$VERSION = '1.23_01';
+$VERSION = eval $VERSION;
+---
+
+$dist->regen;
+$pm_info = Module::Metadata->new_from_file( $file );
+
+is( $pm_info->version, '1.23_01', 'alpha version reported');
+
+# NOTE the following test has be done this way because Test::Builder is
+# too smart for our own good and tries to see if the version object is a
+# dual-var, which breaks with alpha versions:
+#    Argument "1.23_0100" isn't numeric in addition (+) at
+#    /usr/lib/perl5/5.8.7/Test/Builder.pm line 505.
+
+ok( $pm_info->version > 1.23, 'alpha version greater than non');
+
+# revert to pristine state
+$dist->regen( clean => 1 );
+
+# parse $VERSION lines scripts for package main
+my @scripts = (
+  <<'---', # package main declared
+#!perl -w
+package main;
+$VERSION = '0.01';
+---
+  <<'---', # on first non-comment line, non declared package main
+#!perl -w
+$VERSION = '0.01';
+---
+  <<'---', # after non-comment line
+#!perl -w
+use strict;
+$VERSION = '0.01';
+---
+  <<'---', # 1st declared package
+#!perl -w
+package main;
+$VERSION = '0.01';
+package _private;
+$VERSION = '999';
+---
+  <<'---', # 2nd declared package
+#!perl -w
+package _private;
+$VERSION = '999';
+package main;
+$VERSION = '0.01';
+---
+  <<'---', # split package
+#!perl -w
+package main;
+package _private;
+$VERSION = '999';
+package main;
+$VERSION = '0.01';
+---
+  <<'---', # define 'main' version from other package
+package _private;
+$::VERSION = 0.01;
+$VERSION = '999';
+---
+  <<'---', # define 'main' version from other package
+package _private;
+$VERSION = '999';
+$::VERSION = 0.01;
+---
+);
+
+my ( $i, $n ) = ( 1, scalar( @scripts ) );
+foreach my $script ( @scripts ) {
+  $dist->change_file( 'bin/simple.plx', $script );
+  $dist->regen;
+  $pm_info = Module::Metadata->new_from_file(
+              File::Spec->catfile( 'bin', 'simple.plx' ) );
+
+  is( $pm_info->version, '0.01', "correct script version ($i of $n)" );
+  $i++;
+}
+
+
+# examine properties of a module: name, pod, etc
+$dist->change_file( 'lib/Simple.pm', <<'---' );
+package Simple;
+$VERSION = '0.01';
+package Simple::Ex;
+$VERSION = '0.02';
+=head1 NAME
+
+Simple - It's easy.
+
+=head1 AUTHOR
+
+Simple Simon
+
+=cut
+---
+$dist->regen;
+
+$pm_info = Module::Metadata->new_from_module(
+             $dist->name, inc => [ 'lib', @INC ] );
+
+is( $pm_info->name, 'Simple', 'found default package' );
+is( $pm_info->version, '0.01', 'version for default package' );
+
+# got correct version for secondary package
+is( $pm_info->version( 'Simple::Ex' ), '0.02',
+    'version for secondary package' );
+
+my $filename = $pm_info->filename;
+ok( defined( $filename ) && -e $filename,
+    'filename() returns valid path to module file' );
+
+@packages = $pm_info->packages_inside;
+is( @packages, 2, 'found correct number of packages' );
+is( $packages[0], 'Simple', 'packages stored in order found' );
+
+# we can detect presence of pod regardless of whether we are collecting it
+ok( $pm_info->contains_pod, 'contains_pod() succeeds' );
+
+my @pod = $pm_info->pod_inside;
+is_deeply( \@pod, [qw(NAME AUTHOR)], 'found all pod sections' );
+
+is( $pm_info->pod('NONE') , undef,
+    'return undef() if pod section not present' );
+
+is( $pm_info->pod('NAME'), undef,
+    'return undef() if pod section not collected' );
+
+
+# collect_pod
+$pm_info = Module::Metadata->new_from_module(
+             $dist->name, inc => [ 'lib', @INC ], collect_pod => 1 );
+
+my $name = $pm_info->pod('NAME');
+if ( $name ) {
+  $name =~ s/^\s+//;
+  $name =~ s/\s+$//;
+}
+is( $name, q|Simple - It's easy.|, 'collected pod section' );
+
+
+{
+  # Make sure processing stops after __DATA__
+  $dist->change_file( 'lib/Simple.pm', <<'---' );
+package Simple;
+$VERSION = '0.01';
+__DATA__
+*UNIVERSAL::VERSION = sub {
+  foo();
+};
+---
+  $dist->regen;
+
+  $pm_info = Module::Metadata->new_from_file('lib/Simple.pm');
+  is( $pm_info->name, 'Simple', 'found default package' );
+  is( $pm_info->version, '0.01', 'version for default package' );
+  my @packages = $pm_info->packages_inside;
+  is_deeply(\@packages, ['Simple'], 'packages inside');
+}
+
+{
+  # Make sure we handle version.pm $VERSIONs well
+  $dist->change_file( 'lib/Simple.pm', <<'---' );
+package Simple;
+$VERSION = version->new('0.60.' . (qw$Revision: 128 $)[1]);
+package Simple::Simon;
+$VERSION = version->new('0.61.' . (qw$Revision: 129 $)[1]);
+---
+  $dist->regen;
+
+  $pm_info = Module::Metadata->new_from_file('lib/Simple.pm');
+  is( $pm_info->name, 'Simple', 'found default package' );
+  is( $pm_info->version, '0.60.128', 'version for default package' );
+  my @packages = $pm_info->packages_inside;
+  is_deeply([sort @packages], ['Simple', 'Simple::Simon'], 'packages inside');
+  is( $pm_info->version('Simple::Simon'), '0.61.129', 'version for embedded package' );
+}
+
index 03961eb..a266b89 100644 (file)
 /Module/Load.pm
 /Module/Load/Conditional.pm
 /Module/Loaded.pm
+/Module/Metadata.pm
 /Module/Pluggable
 /Module/Pluggable.pm
 /NDBM_File.pm
index 42b7ee5..ea424b9 100644 (file)
@@ -94,6 +94,14 @@ generation task.
 
 =item *
 
+L<Module::Metadata> 1.000002 has been added as a dual-life module.  It gathers
+package and POD information from Perl module files.  It is a standalone module
+based on Module::Build::ModuleInfo for use by other module installation
+toolchain components.  Module::Build::ModuleInfo has been deprecated in
+favor of this module instead.
+
+=item *
+
 L<Perl::OSType> 1.002 has been added as a dual-life module.  It maps Perl
 operating system names (e.g. 'dragonfly' or 'MSWin32') to more generic types
 with standardized names (e.g.  "Unix" or "Windows").  It has been refactored