Author: bernhard
Date: Tue Apr 24 13:44:21 2007
New Revision: 18324
Modified:
trunk/lib/Parrot/Distribution.pm
trunk/t/perl/Parrot_Distribution.t
Log:
#41611: [TODO] Write a test for is_perl_exemption()
Some beautifications in Parrot::Distribution.
Make get_perl_exemption_regexp() independent from the cwd.
Add tests for is_perl_exemption().
Modified: trunk/lib/Parrot/Distribution.pm
==============================================================================
--- trunk/lib/Parrot/Distribution.pm (original)
+++ trunk/lib/Parrot/Distribution.pm Tue Apr 24 13:44:21 2007
@@ -1,4 +1,4 @@
-# Copyright (C) 2004-2006, The Perl Foundation.
+# Copyright (C) 2004-2007, The Perl Foundation.
# $Id$
=head1 NAME
@@ -32,7 +32,6 @@
use strict;
use warnings;
-use Cwd;
use ExtUtils::Manifest;
use File::Spec;
use Parrot::Configure::Step qw(capture_output);
@@ -60,7 +59,9 @@
my ($class) = @_;
return $dist if defined $dist;
+
my $self = bless {}, $class;
+
return $self->_initialize;
}
@@ -100,6 +101,7 @@
sub _croak {
my ( $self, @message ) = @_;
+
require Carp;
Carp::croak(@message);
}
@@ -383,7 +385,7 @@
}
# return only those files which aren't exempt
- return grep { !$self->is_perl_exemption($_) } @perl_files;
+ return grep { ! $self->is_perl_exemption($_) } @perl_files;
}
=item C<is_perl_exemption()>
@@ -401,9 +403,6 @@
sub is_perl_exemption {
my ( $self, $file ) = @_;
- # RT#41611: write a test to make sure these files don't get picked up
- # again... i.e. a test of is_perl_exemption
-
$exemptions ||= $self->get_perl_exemption_regexp();
return $file->path =~ $exemptions;
@@ -419,9 +418,9 @@
sub get_perl_exemption_regexp {
my $self = shift;
- my $cwd = cwd();
- my @paths = map { File::Spec->catdir( $cwd, File::Spec->canonpath($_) ) }
qw{
+ my $parrot_dir = $self->path();
+ my @paths = map { File::Spec->catdir( $parrot_dir,
File::Spec->canonpath($_) ) } qw{
languages/lua/Lua/parser.pm
languages/regex/lib/Regex/Grammar.pm
lib/Class/
@@ -434,7 +433,8 @@
lib/Text/
};
- my $regex = join '|', map { quotemeta } @paths;
+ my $regex = join '|', map { quotemeta $_ } @paths;
+
return qr/^$regex/;
}
@@ -763,6 +763,7 @@
sub generated_files {
my $self = shift;
+
my $generated = ExtUtils::Manifest::maniread('MANIFEST.generated');
my $path = $dist->path();
Modified: trunk/t/perl/Parrot_Distribution.t
==============================================================================
--- trunk/t/perl/Parrot_Distribution.t (original)
+++ trunk/t/perl/Parrot_Distribution.t Tue Apr 24 13:44:21 2007
@@ -1,11 +1,11 @@
#! perl
-# Copyright (C) 2001-2006, The Perl Foundation.
+# Copyright (C) 2001-2007, The Perl Foundation.
# $Id$
use strict;
use warnings;
use lib qw( . lib ../lib ../../lib );
-use Test::More tests => 34;
+use Test::More tests => 38;
use File::Spec;
=head1 NAME
@@ -28,11 +28,7 @@
chdir 't/perl';
my $d = Parrot::Distribution->new();
isa_ok( $d, 'Parrot::Docs::Directory' );
-
-{
- my $d2 = Parrot::Distribution->new;
- ok( $d == $d2, 'Parrot::Distribution is a singleton' );
-}
+ok( $d == Parrot::Distribution->new(), 'Parrot::Distribution is a singleton' );
ok( $d->c_source_file_with_name('pf_items'), 'C source file' );
ok( !$d->c_source_file_with_name('moomoo'), 'C source file not there' );
@@ -52,7 +48,7 @@
ok( $d->file_for_perl_module('Parrot::Docs::Section::Parrot'), 'Perl module
file' );
ok( !$d->file_for_perl_module('Parrot::Dummy'), 'Perl module file not there' );
-my %pmc_source_file_directories = map { ( $_->path => 1 ) }
$d->pmc_source_file_directories;
+my %pmc_source_file_directories = map { $_->path => 1 }
$d->pmc_source_file_directories();
my @old_directory_list = (
'compilers/bcg/src/pmc', 'languages/APL/src/pmc',
@@ -69,44 +65,37 @@
"Directory from hardcoded list $dir found through MANIFEST" );
}
-## perl files
+## perl files and exemptions
{
- my @perl_files;
- ok( ( @perl_files = $d->get_perl_language_files ), 'Got perl files' );
+ my @perl_files = $d->get_perl_language_files();
+ ok( @perl_files, 'Got some perl files' );
+
ok( $d->perl_source_file_with_name('ops2c.pl'), 'Perl source file
(.pl)' );
ok( $d->perl_source_file_with_name('Distribution.pm'), 'Perl source file
(.pm)' );
ok( $d->perl_source_file_with_name('perlcritic.t'), 'Perl source file
(.t)' );
ok( !$d->perl_source_file_with_name('p5rx.t'), 'Not a Perl source
file (.t)' );
-}
-## perl exemptions
-{
- my @perl_exemption_regexp;
- my @perl_files = $d->get_perl_language_files();
- ok( ( @perl_exemption_regexp = $d->get_perl_exemption_regexp ), 'Got perl
exemption regexp' );
+ my $perl_exemption_regexp = $d->get_perl_exemption_regexp();
+ ok( $perl_exemption_regexp, 'Got perl exemption regexp' );
- # check that exemptions found match those expected
- my @perl_exemptions;
- for my $file (@perl_files) {
- push @perl_exemptions, $file->path
- if $d->is_perl_exemption($file);
- }
+ my $exempted_file = Parrot::IO::File->new( '../../lib/SmartLink.pm' );
+ ok( $d->is_perl_exemption( $exempted_file ), 'SmartLink.pm is exempted' );
+ like( $exempted_file->path(), $perl_exemption_regexp, 'SmartLink.pm is
matched' );
+
+ # we are in 't/perl'
+ my $not_exempted_file = Parrot::IO::File->new( '../../lib/DumbLink.pm' );
+ ok( ! $d->is_perl_exemption( $not_exempted_file ), 'DumbLink.pm is not
exempted' );
+ unlike( $not_exempted_file->path(), $perl_exemption_regexp, 'DumbLink.pm
is not matched' );
# check that no exemptions turn up in the main file list
- my @exemptions_in_perl_list;
-
- #print join ' ', @perl_exemption_regexp, "\n";
- for my $file (@perl_files) {
-
- #print $file->path, "\n";
- push @exemptions_in_perl_list, $file->path
- if ( map $file->path =~ m/$_/, @perl_exemption_regexp );
- }
- ok( ( !scalar @exemptions_in_perl_list ), 'No exemptions in Perl source
list' );
- if ( scalar @exemptions_in_perl_list ) {
- for my $exemption (@exemptions_in_perl_list) {
- print $exemption, "\n";
- }
+ my @exemptions_in_perl_list
+ = grep { $_ =~ $perl_exemption_regexp }
+ map { $_->path }
+ @perl_files;
+
+ ok( ! @exemptions_in_perl_list, 'No exemptions in Perl source list' );
+ foreach (@exemptions_in_perl_list) {
+ diag( "got exempted perl file: $_" );
}
}
