From: Vincent Pit Date: Tue, 7 Jul 2009 16:18:02 +0000 (+0200) Subject: Initial import X-Git-Tag: v0.01~1 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FPerl-Critic-Policy-Dynamic-NoIndirect.git;a=commitdiff_plain;h=c2e8dfbf550e0a15ff415a698c806e1fc8ca03fe Initial import --- c2e8dfbf550e0a15ff415a698c806e1fc8ca03fe diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..5d54ad6 --- /dev/null +++ b/.gitignore @@ -0,0 +1,25 @@ +blib* +pm_to_blib* + +Makefile +Makefile.old +Build +_build* + +*.tar.gz +Perl-Critic-Policy-Dynamic-NoIndirect-* + +core.* +*.[co] +*.so +*.bs +*.out +*.def +*.exp + +cover_db +*.gcda +*.gcov +*.gcno + +Debian_CPANTS.txt diff --git a/Changes b/Changes new file mode 100644 index 0000000..53d5031 --- /dev/null +++ b/Changes @@ -0,0 +1,5 @@ +Revision history for Perl-Critic-Policy-Dynamic-NoIndirect + +0.01 + First version. + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..c2616ad --- /dev/null +++ b/MANIFEST @@ -0,0 +1,11 @@ +Changes +META.yml +Makefile.PL +Makefile.old +README +lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm +t/00-load.t +t/91-pod.t +t/92-pod-coverage.t +t/95-portability-files.t +t/99-kwalitee.t diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..3ff6d0f --- /dev/null +++ b/META.yml @@ -0,0 +1,34 @@ +--- #YAML:1.0 +name: Perl-Critic-Policy-Dynamic-NoIndirect +version: 0.01 +abstract: Perl::Critic policy against indirect method calls. +author: + - Vincent Pit +license: perl +distribution_type: module +configure_requires: + ExtUtils::MakeMaker: 0 +build_requires: + ExtUtils::MakeMaker: 0 + Perl::Critic::TestUtils: 0 + Test::More: 0 +requires: + base: 0 + Carp: 0 + indirect: 0.14 + perl: 5.008 + Perl::Critic::DynamicPolicy: 0 + Perl::Critic::Utils: 0 +resources: + bugtracker: http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Perl-Critic-Policy-Dynamic-NoIndirect + homepage: http://search.cpan.org/dist/Perl-Critic-Policy-Dynamic-NoIndirect/ + license: http://dev.perl.org/licenses/ + repository: http://git.profvince.com/?p=perl%2Fmodules%2FPerl-Critic-Policy-Dynamic-NoIndirect.git +no_index: + directory: + - t + - inc +generated_by: ExtUtils::MakeMaker version 6.52 +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: 1.4 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..ea3090f --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,49 @@ +use 5.008; + +use strict; +use warnings; +use ExtUtils::MakeMaker; + +my $dist = 'Perl-Critic-Policy-Dynamic-NoIndirect'; + +my %META = ( + configure_requires => { + 'ExtUtils::MakeMaker' => 0, + }, + build_requires => { + 'ExtUtils::MakeMaker' => 0, + 'Perl::Critic::TestUtils' => 0, + 'Test::More' => 0, + }, + resources => { + bugtracker => "http://rt.cpan.org/NoAuth/ReportBug.html?Queue=$dist", + homepage => "http://search.cpan.org/dist/$dist/", + license => 'http://dev.perl.org/licenses/', + repository => "http://git.profvince.com/?p=perl%2Fmodules%2F$dist.git", + }, +); + +WriteMakefile( + NAME => 'Perl::Critic::Policy::Dynamic::NoIndirect', + AUTHOR => 'Vincent Pit ', + LICENSE => 'perl', + VERSION_FROM => 'lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm', + ABSTRACT_FROM => 'lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm', + PL_FILES => {}, + PREREQ_PM => { + 'Carp' => 0, + 'Perl::Critic::Utils' => 0, + 'Perl::Critic::DynamicPolicy' => 0, + 'base' => 0, + 'indirect' => '0.14', + }, + MIN_PERL_VERSION => 5.008, + META_MERGE => \%META, + dist => { + PREOP => 'pod2text lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm > $(DISTVNAME)/README', + COMPRESS => 'gzip -9f', SUFFIX => 'gz' + }, + clean => { + FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt" + }, +); diff --git a/README b/README new file mode 100644 index 0000000..a60c8d7 --- /dev/null +++ b/README @@ -0,0 +1,46 @@ +NAME + Perl::Critic::Policy::Dynamic::NoIndirect - Perl::Critic policy against + indirect method calls. + +VERSION + Version 0.01 + +DESCRIPTION + This Perl::Critic dynamic policy reports any use of indirect object + syntax with a 'stern' severity. It's listed under the 'dynamic' and + 'maintenance' themes. + + Since it wraps around indirect, it needs to compile the audited code and + as such is implemented as a subclass of Perl::Critic::DynamicPolicy. + +DEPENDENCIES + perl 5.8, Carp. + + Perl::Critic, Perl::Critic::Dynamic. + + indirect. + +AUTHOR + Vincent Pit, "", . + + You can contact me by mail or on "irc.perl.org" (vincent). + +BUGS + Please report any bugs or feature requests to + "bug-perl-critic-policy-dynamic-noindirect at rt.cpan.org", or through + the web interface at + . I will be notified, and then you'll automatically be + notified of progress on your bug as I make changes. + +SUPPORT + You can find documentation for this module with the perldoc command. + + perldoc Perl::Critic::Policy::Dynamic::NoIndirect + +COPYRIGHT & LICENSE + Copyright 2009 Vincent Pit, all rights reserved. + + This program is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. + diff --git a/lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm b/lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm new file mode 100644 index 0000000..5b0ac62 --- /dev/null +++ b/lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm @@ -0,0 +1,143 @@ +package Perl::Critic::Policy::Dynamic::NoIndirect; + +use 5.008; + +use strict; +use warnings; + +=head1 NAME + +Perl::Critic::Policy::Dynamic::NoIndirect - Perl::Critic policy against indirect method calls. + +=head1 VERSION + +Version 0.01 + +=cut + +our $VERSION = '0.01'; + +=head1 DESCRIPTION + +This L dynamic policy reports any use of indirect object syntax with a C<'stern'> severity. +It's listed under the C<'dynamic'> and C<'maintenance'> themes. + +Since it wraps around L, it needs to compile the audited code and as such is implemented as a subclass of L. + +=cut + +use base qw/Perl::Critic::DynamicPolicy/; + +use Perl::Critic::Utils qw/:severities/; + +sub default_severity { $SEVERITY_HIGH } +sub default_themes { qw/dynamic maintenance/ } +sub applies_to { 'PPI::Document' } + +sub violates_dynamic { + my ($self, undef, $doc) = @_; + + my $src; + + if ($doc->isa('PPI::Document::File')) { + my $file = $doc->filename; + open my $fh, '<', $file + or do { require Carp; Carp::confess("Can't open $file for reading: $!") }; + $src = do { local $/; <$fh> }; + } else { + $src = $doc->serialize; + } + + my @errs; + my $offset = 6; + my $wrapper = <<" WRAPPER"; + { + return; + package main; + no indirect hook => sub { push \@errs, [ \@_ ] }; + { + ; + $src + } + } + WRAPPER + + { + local ($@, *_); + eval $wrapper; ## no critic + if ($@) { + require Carp; + Carp::confess("Couldn't compile the source wrapper: $@"); + } + } + + my @violations; + + if (@errs) { + my ($err, $obj, $meth, $line); + + $doc->find(sub { + unless ($err) { + return 1 unless @errs; + $err = shift @errs; + ($obj, $meth, $line) = @$err[0, 1, 3]; + $line -= $offset; + } + + my $elt = $_[1]; + my $pos = $elt->location; + + if ($pos and $pos->[0] == $line and $elt eq $meth + and $elt->snext_sibling eq $obj) { + push @violations, [ $obj, $meth, $elt ]; + undef $err; + } + + return 0; + }); + } + + return map { + my ($obj, $meth, $elt) = @$_; + $self->violation( + "Indirect call of method \"$meth\" on object \"$obj\"", + "You really wanted $obj\->$meth", + $elt, + ); + } @violations; +} + +=head1 DEPENDENCIES + +L 5.8, L. + +L, L. + +L. + +=head1 AUTHOR + +Vincent Pit, C<< >>, L. + +You can contact me by mail or on C (vincent). + +=head1 BUGS + +Please report any bugs or feature requests to C, or through the web interface at L. +I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc Perl::Critic::Policy::Dynamic::NoIndirect + +=head1 COPYRIGHT & LICENSE + +Copyright 2009 Vincent Pit, all rights reserved. + +This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. + +=cut + +1; # End of Perl::Critic::Policy::Dynamic::NoIndirect diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..069bf93 --- /dev/null +++ b/t/00-load.t @@ -0,0 +1,12 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 1; + +BEGIN { + use_ok( 'Perl::Critic::Policy::Dynamic::NoIndirect' ); +} + +diag( "Testing Perl::Critic::Policy::Dynamic::NoIndirect $Perl::Critic::Policy::Dynamic::NoIndirect::VERSION, Perl $], $^X" ); diff --git a/t/10-basic.t b/t/10-basic.t new file mode 100644 index 0000000..abf5a3d --- /dev/null +++ b/t/10-basic.t @@ -0,0 +1,95 @@ +#!perl -T + +use strict; +use warnings; + +my $subtests; +BEGIN { $subtests = 3 } + +use Test::More tests => $subtests * 14; + +use Perl::Critic::TestUtils qw/pcritique_with_violations/; + +Perl::Critic::TestUtils::block_perlcriticrc(); + +my $policy = 'Dynamic::NoIndirect'; + +{ + local $/ = "####"; + + my $id = 1; + + while () { + s/^\s+//s; + + my ($code, $expected) = split /^-+$/m, $_, 2; + my @expected = eval $expected; + + my @violations = eval { pcritique_with_violations($policy, \$code) }; + + if ($@) { + diag "Compilation $id failed: $@"; + next; + } + + for my $v (@violations) { + my $exp = shift @expected; + + unless ($exp) { + fail "Unexpected violation for chunk $id: " . $v->description; + next; + } + + my $pos = $v->location; + my ($meth, $obj, $line, $col) = @$exp; + + like $v->description, + qr/^Indirect call of method \"\Q$meth\E\" on object \"\Q$obj\E\"/, + "description $id"; + is $pos->[0], $line, "line $id"; + is $pos->[1], $col, "column $id"; + } + + ++$id; + } +} + +__DATA__ +my $x = new X; +---- +[ 'new', 'X', 1, 9 ] +#### +my $x = new X; $x = new X; +---- +[ 'new', 'X', 1, 9 ], [ 'new', 'X', 1, 21 ] +#### +my $x = new X new X; +---- +[ 'new', 'X', 1, 9 ], [ 'new', 'X', 1, 18 ] +#### +my $x = new X; +my $y = new X; +---- +[ 'new', 'X', 1, 9 ], [ 'new', 'X', 2, 9 ] +#### +our $obj; +my $x = new $obj; +---- +[ 'new', '$obj', 2, 9 ] +#### +our $obj; +my $x = new $obj; $x = new $obj; +---- +[ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 2, 24 ] +#### +our $obj; +my $x = new $obj new $obj; +---- +[ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 2, 21 ] +#### +our $obj; +my $x = new $obj; +my $y = new $obj; +---- +[ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 3, 9 ] + diff --git a/t/91-pod.t b/t/91-pod.t new file mode 100644 index 0000000..ee8b18a --- /dev/null +++ b/t/91-pod.t @@ -0,0 +1,12 @@ +#!perl -T + +use strict; +use warnings; +use Test::More; + +# Ensure a recent version of Test::Pod +my $min_tp = 1.22; +eval "use Test::Pod $min_tp"; +plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; + +all_pod_files_ok(); diff --git a/t/92-pod-coverage.t b/t/92-pod-coverage.t new file mode 100644 index 0000000..f0d42e7 --- /dev/null +++ b/t/92-pod-coverage.t @@ -0,0 +1,18 @@ +#!perl -T + +use strict; +use warnings; +use Test::More; + +# Ensure a recent version of Test::Pod::Coverage +my $min_tpc = 1.08; +eval "use Test::Pod::Coverage $min_tpc"; +plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; + +# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, +# but older versions don't recognize some common documentation styles +my $min_pc = 0.18; +eval "use Pod::Coverage $min_pc"; +plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; + +all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::CountParents' }); diff --git a/t/95-portability-files.t b/t/95-portability-files.t new file mode 100644 index 0000000..ab541f3 --- /dev/null +++ b/t/95-portability-files.t @@ -0,0 +1,10 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Portability::Files"; +plan skip_all => "Test::Portability::Files required for testing filenames portability" if $@; +run_tests(); diff --git a/t/99-kwalitee.t b/t/99-kwalitee.t new file mode 100644 index 0000000..7775e60 --- /dev/null +++ b/t/99-kwalitee.t @@ -0,0 +1,9 @@ +#!perl + +use strict; +use warnings; + +use Test::More; + +eval { require Test::Kwalitee; Test::Kwalitee->import() }; +plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@;