From 2adc4a427a258fb352ae019b2f0f41d98117e1d3 Mon Sep 17 00:00:00 2001 From: Joshua ben Jore Date: Wed, 29 Nov 2006 08:26:25 -0800 Subject: [PATCH] Re: [PATCH] Make B::Lint use Module::Pluggable From: "Joshua ben Jore" Message-ID: p4raw-id: //depot/perl@29432 --- MANIFEST | 1 + ext/B/B/Lint.pm | 129 +++++++++++++++++++++------------- ext/B/t/lint.t | 42 +++++++---- ext/B/t/pluglib/B/Lint/Plugin/Test.pm | 20 ++++++ 4 files changed, 128 insertions(+), 64 deletions(-) create mode 100644 ext/B/t/pluglib/B/Lint/Plugin/Test.pm diff --git a/MANIFEST b/MANIFEST index 468272f..79e171d 100644 --- a/MANIFEST +++ b/MANIFEST @@ -94,6 +94,7 @@ ext/B/t/f_map.t converted to optreeCheck()s 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 diff --git a/ext/B/B/Lint.pm b/ext/B/B/Lint.pm index e57471b..ee81860 100644 --- a/ext/B/B/Lint.pm +++ b/ext/B/B/Lint.pm @@ -1,6 +1,6 @@ package B::Lint; -our $VERSION = '1.08'; +our $VERSION = '1.09'; ## no critic =head1 NAME @@ -136,18 +136,19 @@ include other package names whose subs are then checked by Lint. =head1 EXTENDING LINT -Lint can be extended by registering plugins. +Lint can be extended by with plugins. Lint uses L +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 => \@new_checks ) >> method -adds the class C 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 then your class name is +added to the list of plugins. You must create a C 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 @@ use B qw( walkoptree_slow 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 @@ sub curcv {$curcv} 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 @@ my @extra_packages; # Lint checks mainline code and all subs which are 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 @@ sub gimme { 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 or C, 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 this # returns true. @@ -317,7 +327,10 @@ for ( # 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 @@ for ( 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 @@ UNDEFINED_SUBS: { 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 @@ UNDEFINED_SUBS: { } 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::GV::lintcv { sub B::CV::lintcv { + # Example: B::svref_2object( \ &foo )->lintcv + # Write to the *global* $ $curcv = shift @_; @@ -652,7 +671,7 @@ sub do_lint { # 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 @@ OPTION: 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 @@ OPTION: 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,20 +754,31 @@ OPTION: 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."; - - $plugin_valid_check{$check} = $plugin; + # Allow the user to be lazy and not give us a name. + $plugin = caller unless defined $plugin; + + # Register the plugin's named checks, if any. + for my $check ( eval {@$new_checks} ) { + 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; } - push @plugins, $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; + } return; } diff --git a/ext/B/t/lint.t b/ext/B/t/lint.t index 05d53d8..f62adc2 100644 --- a/ext/B/t/lint.t +++ b/ext/B/t/lint.t @@ -17,7 +17,7 @@ BEGIN { 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 @@ runlint 'implicit-write', 's/foo/bar/', <<'RESULT'; 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 @@ runlint 'dollar-underscore', '$_ = 1', <<'RESULT'; 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 @@ runlint 'bare-subs', 'sub bare(){1}; $x=[bare=>0]; $x=$y{bare}', <<'RESULT'; 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' ); +} diff --git a/ext/B/t/pluglib/B/Lint/Plugin/Test.pm b/ext/B/t/pluglib/B/Lint/Plugin/Test.pm new file mode 100644 index 0000000..4a63c81 --- /dev/null +++ b/ext/B/t/pluglib/B/Lint/Plugin/Test.pm @@ -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; -- 2.7.4