From: Matt S Trout Date: Tue, 6 Jul 2010 01:27:30 +0000 (+0100) Subject: tests from dagolden (xdg) X-Git-Tag: release_1.0.0~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7a4e305aef966c0b3c2044806e0cc7c74bc4da6b;p=p5sagit%2FModule-Metadata.git tests from dagolden (xdg) --- diff --git a/t/lib/DistGen.pm b/t/lib/DistGen.pm new file mode 100644 index 0000000..9fbd6d0 --- /dev/null +++ b/t/lib/DistGen.pm @@ -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 constructor initializes the object and creates an empty +directory for the distribution. It does not create files or chdir into +the directory. The C 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 +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 option is provided, it defaults to MBTest->tmpdir, which sets +a different temp directory for Perl core testing and CPAN testing. + +The C method does not write any files -- see L 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 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, e.g. 'Foo-Bar' if C is 'Foo::Bar'. + +=item xs + +If true, generates an XS based module. + +=item no_manifest + +If true, C 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 method re-initializes the object as if it were generated +from a fresh call to C. It takes the same optional parameters as C. + + $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. + +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 argument is given, it also calls C. 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). + + $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. Generally, calling C +and C 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/t/lib/MBTest.pm b/t/lib/MBTest.pm new file mode 100644 index 0000000..005920f --- /dev/null +++ b/t/lib/MBTest.pm @@ -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/t/lib/Tie/CPHash.pm b/t/lib/Tie/CPHash.pm new file mode 100644 index 0000000..b167622 --- /dev/null +++ b/t/lib/Tie/CPHash.pm @@ -0,0 +1,194 @@ +#--------------------------------------------------------------------- +package Tie::CPHash; +# +# Copyright 1997 Christopher J. Madsen +# +# Author: Christopher J. Madsen +# 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 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 and C +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 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 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. + +=head1 AUTHOR + +Christopher J. Madsen EFE + +=cut + +# Local Variables: +# tmtrack-file-task: "Tie::CPHash.pm" +# End: diff --git a/t/metadata.t b/t/metadata.t new file mode 100644 index 0000000..40231b3 --- /dev/null +++ b/t/metadata.t @@ -0,0 +1,440 @@ +#!/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 +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' ); +} +