--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+#---------------------------------------------------------------------
+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:
--- /dev/null
+#!/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;
+---
+);
+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' );
+}
+
projects / p5sagit/Module-Metadata.git / commitdiff