Change 29432 by [EMAIL PROTECTED] on 2006/12/01 16:56:01
Subject: Re: [PATCH] Make B::Lint use Module::Pluggable
From: "Joshua ben Jore" <[EMAIL PROTECTED]>
Date: Wed, 29 Nov 2006 16:26:25 -0800
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/MANIFEST#1486 edit
... //depot/perl/ext/B/B/Lint.pm#24 edit
... //depot/perl/ext/B/t/lint.t#19 edit
... //depot/perl/ext/B/t/pluglib/B/Lint/Plugin/Test.pm#1 add
Differences ...
==== //depot/perl/MANIFEST#1486 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#1485~29414~ 2006-11-29 02:19:19.000000000 -0800
+++ perl/MANIFEST 2006-12-01 08:56:01.000000000 -0800
@@ -94,6 +94,7 @@
ext/B/t/f_sort optree test raw material
ext/B/t/f_sort.t optree test raw material
ext/B/t/lint.t See if B::Lint works
+ext/B/t/pluglib/B/Lint/Plugin/Test.pm See if B::Lint works
ext/B/t/OptreeCheck.pm optree comparison tool
ext/B/t/optree_check.t test OptreeCheck apparatus
ext/B/t/optree_concise.t more B::Concise tests
==== //depot/perl/ext/B/B/Lint.pm#24 (text) ====
Index: perl/ext/B/B/Lint.pm
--- perl/ext/B/B/Lint.pm#23~28338~ 2006-05-30 05:21:17.000000000 -0700
+++ perl/ext/B/B/Lint.pm 2006-12-01 08:56:01.000000000 -0800
@@ -1,6 +1,6 @@
package B::Lint;
-our $VERSION = '1.08';
+our $VERSION = '1.09'; ## no critic
=head1 NAME
@@ -136,18 +136,19 @@
=head1 EXTENDING LINT
-Lint can be extended by registering plugins.
+Lint can be extended by with plugins. Lint uses L<Module::Pluggable>
+to find available plugins. Plugins are expected but not required to
+inform Lint of which checks they are adding.
The C<< B::Lint->register_plugin( MyPlugin => [EMAIL PROTECTED] ) >> method
-adds the class C<MyPlugin> to the list of plugins. It also adds the
-list of C<@new_checks> to the list of valid checks.
+adds the list of C<@new_checks> to the list of valid checks. If your
+module wasn't loaded by L<Module::Pluggable> then your class name is
+added to the list of plugins.
You must create a C<match( \%checks )> method in your plugin class or one
of its parents. It will be called on every op as a regular method call
with a hash ref of checks as its parameter.
-You may not alter the %checks hash reference.
-
The class methods C<< B::Lint->file >> and C<< B::Lint->line >> contain
the current filename and line number.
@@ -189,15 +190,27 @@
main_root main_cv walksymtable parents
OPpOUR_INTRO
OPf_WANT_VOID OPf_WANT_LIST OPf_WANT OPf_STACKED SVf_POK );
+use Carp 'carp';
+
+# The current M::P doesn't know about .pmc files.
+use Module::Pluggable ( require => 1 );
+
+use List::Util 'first';
+## no critic Prototypes
+sub any (&@) { my $test = shift @_; $test->() and return 1 for @_; return 0 }
BEGIN {
+
+ # Import or create some constants from B. B doesn't provide
+ # everything I need so some things like OPpCONST_BARE are defined
+ # here.
for my $sym ( qw( begin_av check_av init_av end_av ),
[ 'OPpCONST_BARE' => 64 ] )
{
my $val;
( $sym, $val ) = @$sym if ref $sym;
- if ( grep $sym eq $_, @B::EXPORT_OK, @B::EXPORT ) {
+ if ( any { $sym eq $_ } @B::EXPORT_OK, @B::EXPORT ) {
B->import($sym);
}
else {
@@ -221,24 +234,24 @@
my %check;
my %implies_ok_context;
-BEGIN {
- map( $implies_ok_context{$_}++,
- qw(scalar av2arylen aelem aslice helem hslice
- keys values hslice defined undef delete) );
-}
+map( $implies_ok_context{$_}++,
+ qw(scalar av2arylen aelem aslice helem hslice
+ keys values hslice defined undef delete) );
# Lint checks turned on by default
-my @default_checks = qw(context);
+my @default_checks
+ = qw(context magic_diamond undefined_subs regexp_variables);
my %valid_check;
-my %plugin_valid_check;
# All valid checks
-BEGIN {
- map( $valid_check{$_}++,
- qw(context implicit_read implicit_write dollar_underscore
- private_names bare_subs undefined_subs regexp_variables
- magic_diamond ) );
+for my $check (
+ qw(context implicit_read implicit_write dollar_underscore
+ private_names bare_subs undefined_subs regexp_variables
+ magic_diamond )
+ )
+{
+ $valid_check{$check} = __PACKAGE__;
}
# Debugging options
@@ -251,7 +264,7 @@
sub warning {
my $format = ( @_ < 2 ) ? "%s" : shift @_;
warn sprintf( "$format at %s line %d\n", @_, $file, $line );
- return undef;
+ return undef; ## no critic undef
}
# This gimme can't cope with context that's only determined
@@ -262,26 +275,23 @@
if ( $flags & OPf_WANT ) {
return ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ? 1 : 0 );
}
- return undef;
+ return undef; ## no critic undef
}
-my @plugins;
+my @plugins = __PACKAGE__->plugins;
sub inside_grepmap {
# A boolean function to be used while inside a B::walkoptree_slow
# call. If we are in the EXPR part of C<grep EXPR, ...> or C<grep
# { EXPR } ...>, this returns true.
- for my $ancestor ( @{ parents() } ) {
- my $name = $ancestor->name;
-
- return 1 if $name =~ m/\A(?:grep|map)/xms;
- }
- return 0;
+ return any { $_->name =~ m/\A(?:grep|map)/xms } @{ parents() };
}
sub inside_foreach_modifier {
+ # TODO: use any()
+
# A boolean function to be used while inside a B::walkoptree_slow
# call. If we are in the EXPR part of C<EXPR foreach ...> this
# returns true.
@@ -317,7 +327,10 @@
# currently ignoring $cv->DEPTH and that might be at my peril.
my ( $subname, $attr, $pad_attr ) = @$_;
- my $target = do { no strict 'refs'; \*$subname };
+ my $target = do { ## no critic strict
+ no strict 'refs';
+ \*$subname;
+ };
*$target = sub {
my ($op) = @_;
@@ -325,13 +338,14 @@
if ( not $op->isa('B::PADOP') ) {
$elt = $op->$attr;
}
- return $elt if ref($elt) and $elt->isa('B::SV');
+ return $elt if eval { $elt->isa('B::SV') };
my $ix = $op->$pad_attr;
my @entire_pad = $curcv->PADLIST->ARRAY;
my @elts = map +( $_->ARRAY )[$ix], @entire_pad;
- ($elt)
- = grep { ref() and $_->isa('B::SV') }
+ ($elt) = first {
+ eval { $_->isa('B::SV') } ? $_ : ();
+ }
@elts[ 0, reverse 1 .. $#elts ];
return $elt;
};
@@ -603,7 +617,7 @@
my $gv = $op->gv_harder;
my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
- no strict 'refs';
+ no strict 'refs'; ## no critic strict
if ( not exists &$subname ) {
$subname =~ s/\Amain:://;
warning q[Nonexistant subroutine '%s' called], $subname;
@@ -621,6 +635,9 @@
}
sub B::GV::lintcv {
+
+ # Example: B::svref_2object( \ *A::Glob )->lintcv
+
my $gv = shift @_;
my $cv = $gv->CV;
return unless $cv->can('lintcv');
@@ -630,6 +647,8 @@
sub B::CV::lintcv {
+ # Example: B::svref_2object( \ &foo )->lintcv
+
# Write to the *global* $
$curcv = shift @_;
@@ -652,7 +671,7 @@
# Do all the miscellaneous non-sub blocks.
for my $av ( begin_av, init_av, check_av, end_av ) {
- next unless ref($av) and $av->can('ARRAY');
+ next unless eval { $av->isa('B::AV') };
for my $cv ( $av->ARRAY ) {
next unless ref($cv) and $cv->FILE eq $0;
$cv->lintcv;
@@ -709,7 +728,7 @@
foreach my $opt ( @default_checks, @options ) {
$opt =~ tr/-/_/;
if ( $opt eq "all" ) {
- %check = ( %valid_check, %plugin_valid_check );
+ %check = %valid_check;
}
elsif ( $opt eq "none" ) {
%check = ();
@@ -721,9 +740,8 @@
else {
$check{$opt} = 1;
}
- warn "No such check: $opt\n"
- unless defined $valid_check{$opt}
- or defined $plugin_valid_check{$opt};
+ carp "No such check: $opt"
+ unless defined $valid_check{$opt};
}
}
@@ -736,21 +754,32 @@
sub register_plugin {
my ( undef, $plugin, $new_checks ) = @_;
- # Register the plugin
- for my $check (@$new_checks) {
- defined $check
- or warn "Undefined value in checks.";
- not $valid_check{$check}
- or warn "$check is already registered as a B::Lint feature.";
- not $plugin_valid_check{$check}
- or warn
- "$check is already registered as a $plugin_valid_check{$check}
feature.";
+ # Allow the user to be lazy and not give us a name.
+ $plugin = caller unless defined $plugin;
- $plugin_valid_check{$check} = $plugin;
+ # Register the plugin's named checks, if any.
+ for my $check ( eval [EMAIL PROTECTED] ) {
+ if ( not defined $check ) {
+ carp 'Undefined value in checks.';
+ next;
+ }
+ if ( exists $valid_check{$check} ) {
+ carp
+ "$check is already registered as a $valid_check{$check}
feature.";
+ next;
+ }
+
+ $valid_check{$check} = $plugin;
+ }
+
+ # Register a non-Module::Pluggable loaded module. @plugins already
+ # contains whatever M::P found on disk. The user might load a
+ # plugin manually from some arbitrary namespace and ask for it to
+ # be registered.
+ if ( not any { $_ eq $plugin } @plugins ) {
+ push @plugins, $plugin;
}
- push @plugins, $plugin;
-
return;
}
==== //depot/perl/ext/B/t/lint.t#19 (text) ====
Index: perl/ext/B/t/lint.t
--- perl/ext/B/t/lint.t#18~28338~ 2006-05-30 05:21:17.000000000 -0700
+++ perl/ext/B/t/lint.t 2006-12-01 08:56:01.000000000 -0800
@@ -17,7 +17,7 @@
require 'test.pl';
}
-plan tests => 28;
+plan tests => 29;
# Runs a separate perl interpreter with the appropriate lint options
# turned on
@@ -67,16 +67,6 @@
Implicit substitution on $_ at -e line 1
RESULT
-{
- my $res = runperl(
- switches => ["-MB::Lint"],
- prog =>
- 'BEGIN{B::Lint->register_plugin(X=>[q[x]])};use O(qw[Lint x]);sub
X::match{warn qq[X ok.\n]};dummy()',
- stderr => 1,
- );
- like( $res, qr/X ok\./, 'Lint plugin' );
-}
-
runlint 'implicit-read', 'for ( @ARGV ) { 1 }',
<<'RESULT', 'implicit-read in foreach';
Implicit use of $_ in foreach at -e line 1
@@ -88,9 +78,9 @@
Use of $_ at -e line 1
RESULT
-runlint 'dollar-underscore', 'foo( $_ ) for @A', '';
-runlint 'dollar-underscore', 'map { foo( $_ ) } @A', '';
-runlint 'dollar-underscore', 'grep { foo( $_ ) } @A', '';
+runlint 'dollar-underscore', 'sub foo {}; foo( $_ ) for @A', '';
+runlint 'dollar-underscore', 'sub foo {}; map { foo( $_ ) } @A', '';
+runlint 'dollar-underscore', 'sub foo {}; grep { foo( $_ ) } @A', '';
runlint 'dollar-underscore', 'print',
<<'RESULT', 'dollar-underscore in print';
@@ -132,3 +122,27 @@
Bare sub name 'bare' interpreted as string at -e line 1
Bare sub name 'bare' interpreted as string at -e line 1
RESULT
+
+{
+
+ # Check for backwards-compatible plugin support. This was where
+ # preloaded mdoules would register themselves with B::Lint.
+ my $res = runperl(
+ switches => ["-MB::Lint"],
+ prog =>
+ 'BEGIN{B::Lint->register_plugin(X=>[q[x]])};use O(qw[Lint x]);sub
X::match{warn qq[X ok.\n]};dummy()',
+ stderr => 1,
+ );
+ like( $res, qr/X ok\./, 'Lint legacy plugin' );
+}
+
+{
+
+ # Check for Module::Plugin support
+ my $res = runperl(
+ switches => [ '-I../ext/B/t/pluglib', '-MO=Lint,none' ],
+ prog => 1,
+ stderr => 1,
+ );
+ like( $res, qr/Module::Pluggable ok\./, 'Lint uses Module::Pluggable' );
+}
==== //depot/perl/ext/B/t/pluglib/B/Lint/Plugin/Test.pm#1 (text) ====
Index: perl/ext/B/t/pluglib/B/Lint/Plugin/Test.pm
--- /dev/null 2006-11-16 10:04:37.532058837 -0800
+++ perl/ext/B/t/pluglib/B/Lint/Plugin/Test.pm 2006-12-01 08:56:01.000000000
-0800
@@ -0,0 +1,20 @@
+package B::Lint::Plugin::Test;
+use strict;
+use warnings;
+
+# This package will be loaded automatically by Module::Plugin when
+# B::Lint loads.
+warn 'got here!';
+
+sub match {
+ my $op = shift @_;
+
+ # Prints to STDERR which will be picked up by the test running in
+ # lint.t
+ warn "Module::Pluggable ok.\n";
+
+ # Ignore this method once it happens once.
+ *match = sub { };
+}
+
+1;
End of Patch.
