This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: B::Lint changes
authorJoshua ben Jore <jjore@cpan.org>
Thu, 18 May 2006 08:45:30 +0000 (03:45 -0500)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Tue, 30 May 2006 12:21:17 +0000 (12:21 +0000)
From: "Joshua ben Jore" <twists@gmail.com>
Message-ID: <dc5c751d0605180645q63ddba5fga354d2660a4877f5@mail.gmail.com>

p4raw-id: //depot/perl@28338

ext/B/B/Lint.pm
ext/B/t/lint.t

index ebd0a7a..e57471b 100644 (file)
@@ -1,6 +1,6 @@
 package B::Lint;
 
-our $VERSION = '1.06';
+our $VERSION = '1.08';
 
 =head1 NAME
 
@@ -29,6 +29,20 @@ override earlier ones. Available options are:
 
 =over 8
 
+=item B<magic-diamond>
+
+Produces a warning whenever the magic C<E<lt>E<gt>> readline is
+used. Internally it uses perl's two-argument open which itself treats
+filenames with special characters specially. This could allow
+interestingly named files to have unexpected effects when reading.
+
+  % touch 'rm *|'
+  % perl -pe 1
+
+The above creates a file named C<rm *|>. When perl opens it with
+C<E<lt>E<gt>> it actually executes the shell program C<rm *>. This
+makes C<E<lt>E<gt>> dangerous to use carelessly.
+
 =item B<context>
 
 Produces a warning whenever an array is used in an implicit scalar
@@ -142,18 +156,28 @@ the current filename and line number.
   B::Lint->register_plugin( Sample => [ 'good_taste' ] );
   
   sub match {
-      my ( $op, $checks_href ) = shift;
+      my ( $op, $checks_href ) = shift @_;
       if ( $checks_href->{good_taste} ) {
           ...
       }
   }
 
+=head1 TODO
+
+=over
+
+=item while(<FH>) stomps $_
+
+=item strict oo
+
+=item unchecked system calls
+
+=item more tests, validate against older perls
+
 =head1 BUGS
 
 This is only a very preliminary version.
 
-This module doesn't work correctly on thread-enabled perls.
-
 =head1 AUTHOR
 
 Malcolm Beattie, mbeattie@sable.ox.ac.uk.
@@ -161,26 +185,46 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk.
 =cut
 
 use strict;
-use B qw(walkoptree_slow main_root walksymtable svref_2object parents
-         class
-         OPpOUR_INTRO
-         OPf_WANT_VOID OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY SVf_POK
-        );
+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 );
 
-my $file = "unknown";          # shadows current filename
-my $line = 0;                  # shadows current line number
-my $curstash = "main";         # shadows current stash
+BEGIN {
+    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 ) {
+            B->import($sym);
+        }
+        else {
+            require constant;
+            constant->import( $sym => $val );
+        }
+    }
+}
+
+my $file     = "unknown";    # shadows current filename
+my $line     = 0;            # shadows current line number
+my $curstash = "main";       # shadows current stash
+my $curcv;                   # shadows current B::CV for pad lookups
 
-sub file { $file }
-sub line { $line }
+sub file     {$file}
+sub line     {$line}
+sub curstash {$curstash}
+sub curcv    {$curcv}
 
 # Lint checks
 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
@@ -188,307 +232,503 @@ my @default_checks = qw(context);
 
 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));
+    map( $valid_check{$_}++,
+        qw(context implicit_read implicit_write dollar_underscore
+            private_names bare_subs undefined_subs regexp_variables
+            magic_diamond ) );
 }
 
 # Debugging options
 my ($debug_op);
 
-my %done_cv;           # used to mark which subs have already been linted
-my @extra_packages;    # Lint checks mainline code and all subs which are
-                       # in main:: or in one of these packages.
+my %done_cv;           # used to mark which subs have already been linted
+my @extra_packages;    # Lint checks mainline code and all subs which are
+                       # in main:: or in one of these packages.
 
 sub warning {
-    my $format = (@_ < 2) ? "%s" : shift;
-    warn sprintf("$format at %s line %d\n", @_, $file, $line);
+    my $format = ( @_ < 2 ) ? "%s" : shift @_;
+    warn sprintf( "$format at %s line %d\n", @_, $file, $line );
+    return undef;
 }
 
 # This gimme can't cope with context that's only determined
 # at runtime via dowantarray().
 sub gimme {
-    my $op = shift;
+    my $op    = shift @_;
     my $flags = $op->flags;
-    if ($flags & OPf_WANT) {
-       return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0);
+    if ( $flags & OPf_WANT ) {
+        return ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ? 1 : 0 );
     }
     return undef;
 }
 
 my @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;
+}
+
+sub inside_foreach_modifier {
+
+    # 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.
+    for my $ancestor ( @{ parents() } ) {
+        next unless $ancestor->name eq 'leaveloop';
+
+        my $first = $ancestor->first;
+        next unless $first->name eq 'enteriter';
+
+        next if $first->redoop->name =~ m/\A(?:next|db|set)state\z/xms;
+
+        return 1;
+    }
+    return 0;
+}
+
+for (
+    [qw[ B::PADOP::gv_harder gv padix]],
+    [qw[ B::SVOP::sv_harder  sv targ]],
+    [qw[ B::SVOP::gv_harder gv padix]]
+    )
+{
+
+    # I'm generating some functions here because they're mostly
+    # similar. It's all for compatibility with threaded
+    # perl. Perhaps... this code should inspect $Config{usethreads}
+    # and generate a *specific* function. I'm leaving it generic for
+    # the moment.
+    #
+    # In threaded perl SVs and GVs aren't used directly in the optrees
+    # like they are in non-threaded perls. The ops that would use a SV
+    # or GV keep an index into the subroutine's scratchpad. I'm
+    # currently ignoring $cv->DEPTH and that might be at my peril.
+
+    my ( $subname, $attr, $pad_attr ) = @$_;
+    my $target = do { no strict 'refs'; \*$subname };
+    *$target = sub {
+        my ($op) = @_;
+
+        my $elt;
+        if ( not $op->isa('B::PADOP') ) {
+            $elt = $op->$attr;
+        }
+        return $elt if ref($elt) and $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') }
+            @elts[ 0, reverse 1 .. $#elts ];
+        return $elt;
+    };
+}
+
 sub B::OP::lint {
-    my $op = shift;
+    my ($op) = @_;
+
+    # This is a fallback ->lint for all the ops where I haven't
+    # defined something more specific. Nothing happens here.
+
+    # Call all registered plugins
     my $m;
-    $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
+    $m = $_->can('match'), $op->$m( \%check ) for @plugins;
     return;
 }
 
-*$_ = *B::OP::lint
-  for \ ( *B::PADOP::lint,
-          *B::LOGOP::lint,
-          *B::BINOP::lint,
-          *B::LISTOP::lint );
-
 sub B::COP::lint {
-    my $op = shift;
-    if ($op->name eq "nextstate") {
-       $file = $op->file;
-       $line = $op->line;
-       $curstash = $op->stash->NAME;
+    my ($op) = @_;
+
+    # nextstate ops sit between statements. Whenever I see one I
+    # update the current info on file, line, and stash. This code also
+    # updates it when it sees a dbstate or setstate op. I have no idea
+    # what those are but having seen them mentioned together in other
+    # parts of the perl I think they're kind of equivalent.
+    if ( $op->name =~ m/\A(?:next|db|set)state\z/ ) {
+        $file     = $op->file;
+        $line     = $op->line;
+        $curstash = $op->stash->NAME;
     }
 
+    # Call all registered plugins
     my $m;
-    $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
+    $m = $_->can('match'), $op->$m( \%check ) for @plugins;
     return;
 }
 
 sub B::UNOP::lint {
-    my $op = shift;
+    my ($op) = @_;
+
     my $opname = $op->name;
-    if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) {
-       my $parent = parents->[0];
-       my $pname = $parent->name;
-       return if gimme($op) || $implies_ok_context{$pname};
-       # Three special cases to deal with: "foreach (@foo)", "delete $a{$b}", and "exists $a{$b}"
-       # null out the parent so we have to check for a parent of pp_null and
-       # a grandparent of pp_enteriter, pp_delete, pp_exists
-       if ($pname eq "null") {
-           my $gpname = parents->[1]->name;
-           return if $gpname eq "enteriter"
-                   or $gpname eq "delete"
-                   or $gpname eq "exists";
-       }
-       
-       # our( @bar );
-       return if $op->private & OPpOUR_INTRO
-                  and ( $op->flags & OPf_WANT ) == OPf_WANT_VOID;
-       
-       warning("Implicit scalar context for %s in %s",
-               $opname eq "rv2av" ? "array" : "hash", $parent->desc);
+
+CONTEXT: {
+
+        # Check arrays and hashes in scalar or void context where
+        # scalar() hasn't been used.
+
+        next
+            unless $check{context}
+            and $opname =~ m/\Arv2[ah]v\z/xms
+            and not gimme($op);
+
+        my ( $parent, $gparent ) = @{ parents() }[ 0, 1 ];
+        my $pname = $parent->name;
+
+        next if $implies_ok_context{$pname};
+
+        # Three special cases to deal with: "foreach (@foo)", "delete
+        # $a{$b}", and "exists $a{$b}" null out the parent so we have to
+        # check for a parent of pp_null and a grandparent of
+        # pp_enteriter, pp_delete, pp_exists
+
+        next
+            if $pname eq "null"
+            and $gparent->name =~ m/\A(?:delete|enteriter|exists)\z/xms;
+
+        # our( @bar ); would also trigger this error so I exclude
+        # that.
+        next
+            if $op->private & OPpOUR_INTRO
+            and ( $op->flags & OPf_WANT ) == OPf_WANT_VOID;
+
+        warning 'Implicit scalar context for %s in %s',
+            $opname eq "rv2av" ? "array" : "hash", $parent->desc;
     }
-    if ($check{private_names} && $opname eq "method") {
-       my $methop = $op->first;
-       if ($methop->name eq "const") {
-           my $method = $methop->sv->PV;
-           if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
-               warning("Illegal reference to private method name $method");
-           }
-       }
+
+PRIVATE_NAMES: {
+
+        # Looks for calls to methods with names that begin with _ and
+        # that aren't visible within the current package. Maybe this
+        # should look at @ISA.
+        next
+            unless $check{private_names}
+            and $opname =~ m/\Amethod/xms;
+
+        my $methop = $op->first;
+        next unless $methop->name eq "const";
+
+        my $method = $methop->sv_harder->PV;
+        next
+            unless $method =~ m/\A_/xms
+            and not defined &{"$curstash\::$method"};
+
+        warning q[Illegal reference to private method name '%s'], $method;
     }
 
+    # Call all registered plugins
     my $m;
-    $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
+    $m = $_->can('match'), $op->$m( \%check ) for @plugins;
     return;
 }
 
 sub B::PMOP::lint {
-    my $op = shift;
-    if ($check{implicit_read}) {
-       if ($op->name eq "match"
-               and not ( $op->flags & OPf_STACKED
-                   or join( " ",
-                       map $_->name,
-                       @{B::parents()} )
-               =~ /^(?:leave )?(?:null )*grep/ ) ) {
-           warning('Implicit match on $_');
-       }
+    my ($op) = @_;
+
+IMPLICIT_READ: {
+
+        # Look for /.../ that doesn't use =~ to bind to something.
+        next
+            unless $check{implicit_read}
+            and $op->name eq "match"
+            and not( $op->flags & OPf_STACKED
+            or inside_grepmap() );
+        warning 'Implicit match on $_';
     }
-    if ($check{implicit_write}) {
-       if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) {
-           warning('Implicit substitution on $_');
-       }
+
+IMPLICIT_WRITE: {
+
+        # Look for s/.../.../ that doesn't use =~ to bind to
+        # something.
+        next
+            unless $check{implicit_write}
+            and $op->name eq "subst"
+            and not $op->flags & OPf_STACKED;
+        warning 'Implicit substitution on $_';
     }
 
+    # Call all registered plugins
     my $m;
-    $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
+    $m = $_->can('match'), $op->$m( \%check ) for @plugins;
     return;
 }
 
 sub B::LOOP::lint {
-    my $op = shift;
-    if ($check{implicit_read} || $check{implicit_write}) {
-       if ($op->name eq "enteriter") {
-           my $last = $op->last;
-           my $body = $op->redoop;
-           if ( $last->name eq "gv"
-                and $last->gv->NAME eq "_"
-                and $body->name =~ /\A(?:next|db|set)state\z/ ) {
-               warning('Implicit use of $_ in foreach');
-           }
-       }
+    my ($op) = @_;
+
+IMPLICIT_FOO: {
+
+        # Look for C<for ( ... )>.
+        next
+            unless ( $check{implicit_read} or $check{implicit_write} )
+            and $op->name eq "enteriter";
+
+        my $last = $op->last;
+        next
+            unless $last->name         eq "gv"
+            and $last->gv_harder->NAME eq "_"
+            and $op->redoop->name =~ m/\A(?:next|db|set)state\z/xms;
+
+        warning 'Implicit use of $_ in foreach';
     }
-    
+
+    # Call all registered plugins
     my $m;
-    $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
+    $m = $_->can('match'), $op->$m( \%check ) for @plugins;
     return;
 }
 
-sub _inside_foreach_statement {
-    for my $op ( @{ parents() || [] } ) {
-       $op->name eq 'leaveloop' or next;
-       my $first = $op->first;
-       $first->name eq 'enteriter' or next;
-       $first->redoop->name !~ /\A(?:next|db|set)state\z/ or next;
-       return 1;
-    }
-    return 0;
-}
+# In threaded vs non-threaded perls you'll find that threaded perls
+# use PADOP in place of SVOPs so they can do lookups into the
+# scratchpad to find things. I suppose this is so a optree can be
+# shared between threads and all symbol table muckery will just get
+# written to a scratchpad.
+*B::PADOP::lint = \&B::SVOP::lint;
 
 sub B::SVOP::lint {
-    my $op = shift;
-    if ( $check{bare_subs} && $op->name eq 'const'
-         && $op->private & 64 )                # OPpCONST_BARE = 64 in op.h
-    {
-       my $sv = $op->sv;
-       if( $sv->FLAGS & SVf_POK && exists &{$curstash.'::'.$sv->PV} ) {
-           warning "Bare sub name '" . $sv->PV . "' interpreted as string";
-       }
+    my ($op) = @_;
+
+MAGIC_DIAMOND: {
+        next
+            unless $check{magic_diamond}
+            and parents()->[0]->name eq 'readline'
+            and $op->gv_harder->NAME eq 'ARGV';
+
+        warning 'Use of <>';
     }
-    if ($check{dollar_underscore}
-       and $op->name eq "gvsv"
-       and $op->gv->NAME eq "_"
-       and not ( _inside_foreach_statement()
-                 or do { my $ctx = join( ' ',
-                                         map $_->name,
-                                         @{ parents() || [] } );
-                         $ctx =~ /(grep|map)start \1while/ } ) )
-    {
-       warning('Use of $_');
+
+BARE_SUBS: {
+        next
+            unless $check{bare_subs}
+            and $op->name eq 'const'
+            and $op->private & OPpCONST_BARE;
+
+        my $sv = $op->sv_harder;
+        next unless $sv->FLAGS & SVf_POK;
+
+        my $sub     = $sv->PV;
+        my $subname = "$curstash\::$sub";
+
+        # I want to skip over things that were declared with the
+        # constant pragma. Well... sometimes. Hmm. I want to ignore
+        # C<<use constant FOO => ...>> but warn on C<<FOO => ...>>
+        # later. The former is typical declaration syntax and the
+        # latter would be an error.
+        #
+        # Skipping over both could be handled by looking if
+        # $constant::declared{$subname} is true.
+
+        # Check that it's a function.
+        next
+            unless exists &{"$curstash\::$sub"};
+
+        warning q[Bare sub name '%s' interpreted as string], $sub;
+    }
+
+PRIVATE_NAMES: {
+        next unless $check{private_names};
+
+        my $opname = $op->name;
+        if ( $opname =~ m/\Agv(?:sv)?\z/xms ) {
+
+            # Looks for uses of variables and stuff that are named
+            # private and we're not in the same package.
+            my $gv   = $op->gv_harder;
+            my $name = $gv->NAME;
+            next
+                unless $name =~ m/\A_./xms
+                and $gv->STASH->NAME ne $curstash;
+
+            warning q[Illegal reference to private name '%s'], $name;
+        }
+        elsif ( $opname eq "method_named" ) {
+            my $method = $op->sv_harder->PV;
+            next unless $method =~ m/\A_./xms;
+
+            warning q[Illegal reference to private method name '%s'], $method;
+        }
     }
-    if ($check{private_names}) {
-       my $opname = $op->name;
-       if ($opname eq "gv" || $opname eq "gvsv") {
-           my $gv = $op->gv;
-           if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) {
-               warning('Illegal reference to private name %s', $gv->NAME);
-           }
-       } elsif ($opname eq "method_named") {
-           my $method = $op->gv->PV;
-           if ($method =~ /^_./) {
-               warning("Illegal reference to private method name $method");
-           }
-       }
+
+DOLLAR_UNDERSCORE: {
+
+        # Warn on uses of $_ with a few exceptions. I'm not warning on
+        # $_ inside grep, map, or statement modifer foreach because
+        # they localize $_ and it'd be impossible to use these
+        # features without getting warnings.
+
+        next
+            unless $check{dollar_underscore}
+            and $op->name            eq "gvsv"
+            and $op->gv_harder->NAME eq "_"
+            and not( inside_grepmap
+            or inside_foreach_modifier );
+
+        warning 'Use of $_';
     }
-    if ($check{undefined_subs}) {
-       if ($op->name eq "gv"
-           && $op->next->name eq "entersub")
-       {
-           my $gv = $op->gv;
-           my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
-           no strict 'refs';
-           if (!defined(&$subname)) {
-               $subname =~ s/^main:://;
-               warning('Undefined subroutine %s called', $subname);
-           }
-       }
+
+REGEXP_VARIABLES: {
+
+        # Look for any uses of $`, $&, or $'.
+        next
+            unless $check{regexp_variables}
+            and $op->name eq "gvsv";
+
+        my $name = $op->gv_harder->NAME;
+        next unless $name =~ m/\A[\&\'\`]\z/xms;
+
+        warning 'Use of regexp variable $%s', $name;
     }
-    if ($check{regexp_variables} && $op->name eq "gvsv") {
-       my $name = $op->gv->NAME;
-       if ($name =~ /^[&'`]$/) {
-           warning('Use of regexp variable $%s', $name);
-       }
+
+UNDEFINED_SUBS: {
+
+        # Look for calls to functions that either don't exist or don't
+        # have a definition.
+        next
+            unless $check{undefined_subs}
+            and $op->name       eq "gv"
+            and $op->next->name eq "entersub";
+
+        my $gv      = $op->gv_harder;
+        my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
+
+        no strict 'refs';
+        if ( not exists &$subname ) {
+            $subname =~ s/\Amain:://;
+            warning q[Nonexistant subroutine '%s' called], $subname;
+        }
+        elsif ( not defined &$subname ) {
+            $subname =~ s/\A\&?main:://;
+            warning q[Undefined subroutine '%s' called], $subname;
+        }
     }
-    
+
+    # Call all registered plugins
     my $m;
-    $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
+    $m = $_->can('match'), $op->$m( \%check ) for @plugins;
     return;
 }
 
 sub B::GV::lintcv {
-    my $gv = shift;
+    my $gv = shift @_;
     my $cv = $gv->CV;
+    return unless $cv->can('lintcv');
+    $cv->lintcv;
+    return;
+}
+
+sub B::CV::lintcv {
+
+    # Write to the *global* $
+    $curcv = shift @_;
+
     #warn sprintf("lintcv: %s::%s (done=%d)\n",
-    #           $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
-    return if !$$cv || $done_cv{$$cv}++;
-    my $root = $cv->ROOT;
+    #           $gv->STASH->NAME, $gv->NAME, $done_cv{$$curcv});#debug
+    return unless ref($curcv) and $$curcv and not $done_cv{$$curcv}++;
+    my $root = $curcv->ROOT;
+
     #warn "    root = $root (0x$$root)\n";#debug
-    walkoptree_slow($root, "lint") if $$root;
+    walkoptree_slow( $root, "lint" ) if $$root;
+    return;
 }
 
 sub do_lint {
     my %search_pack;
-    walkoptree_slow(main_root, "lint") if ${main_root()};
-    
-    # Now do subs in main
-    no strict qw(vars refs);
-    local(*glob);
-    for my $sym (keys %main::) {
-       next if $sym =~ /::$/;
-       *glob = $main::{$sym};
-       
-        # When is EGV a special value?
-        my $gv = svref_2object(\*glob)->EGV;
-        next if class( $gv ) eq 'SPECIAL';
-        $gv->lintcv;
+
+    # Copy to the global $curcv for use in pad lookups.
+    $curcv = main_cv;
+    walkoptree_slow( main_root, "lint" ) if ${ main_root() };
+
+    # 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');
+        for my $cv ( $av->ARRAY ) {
+            next unless ref($cv) and $cv->FILE eq $0;
+            $cv->lintcv;
+        }
     }
 
-    # Now do subs in non-main packages given by -u options
-    map { $search_pack{$_} = 1 } @extra_packages;
-    walksymtable(\%{"main::"}, "lintcv", sub {
-       my $package = shift;
-       $package =~ s/::$//;
-       #warn "Considering $package\n";#debug
-       return exists $search_pack{$package};
-    });
+    walksymtable(
+        \%main::,
+        sub {
+            if ( $_[0]->FILE eq $0 ) { $_[0]->lintcv }
+        },
+        sub {1}
+    );
+    return;
 }
 
 sub compile {
     my @options = @_;
-    my ($option, $opt, $arg);
+
     # Turn on default lint checks
-    for $opt (@default_checks) {
-       $check{$opt} = 1;
+    for my $opt (@default_checks) {
+        $check{$opt} = 1;
     }
-  OPTION:
-    while ($option = shift @options) {
-       if ($option =~ /^-(.)(.*)/) {
-           $opt = $1;
-           $arg = $2;
-       } else {
-           unshift @options, $option;
-           last OPTION;
-       }
-       if ($opt eq "-" && $arg eq "-") {
-           shift @options;
-           last OPTION;
-       } elsif ($opt eq "D") {
+
+OPTION:
+    while ( my $option = shift @options ) {
+        my ( $opt, $arg );
+        unless ( ( $opt, $arg ) = $option =~ m/\A-(.)(.*)/xms ) {
+            unshift @options, $option;
+            last OPTION;
+        }
+
+        if ( $opt eq "-" && $arg eq "-" ) {
+            shift @options;
+            last OPTION;
+        }
+        elsif ( $opt eq "D" ) {
             $arg ||= shift @options;
-           foreach $arg (split(//, $arg)) {
-               if ($arg eq "o") {
-                   B->debug(1);
-               } elsif ($arg eq "O") {
-                   $debug_op = 1;
-               }
-           }
-       } elsif ($opt eq "u") {
-           $arg ||= shift @options;
-           push(@extra_packages, $arg);
-       }
+            foreach my $arg ( split //, $arg ) {
+                if ( $arg eq "o" ) {
+                    B->debug(1);
+                }
+                elsif ( $arg eq "O" ) {
+                    $debug_op = 1;
+                }
+            }
+        }
+        elsif ( $opt eq "u" ) {
+            $arg ||= shift @options;
+            push @extra_packages, $arg;
+        }
     }
-    foreach $opt (@default_checks, @options) {
-       $opt =~ tr/-/_/;
-       if ($opt eq "all") {
+
+    foreach my $opt ( @default_checks, @options ) {
+        $opt =~ tr/-/_/;
+        if ( $opt eq "all" ) {
             %check = ( %valid_check, %plugin_valid_check );
-       }
-       elsif ($opt eq "none") {
-           %check = ();
-       }
-       else {
-           if ($opt =~ s/^no_//) {
-               $check{$opt} = 0;
-           }
-           else {
-               $check{$opt} = 1;
-           }
-           warn "No such check: $opt\n" unless defined $valid_check{$opt}
-                                             or defined $plugin_valid_check{$opt};
-       }
+        }
+        elsif ( $opt eq "none" ) {
+            %check = ();
+        }
+        else {
+            if ( $opt =~ s/\Ano_//xms ) {
+                $check{$opt} = 0;
+            }
+            else {
+                $check{$opt} = 1;
+            }
+            warn "No such check: $opt\n"
+                unless defined $valid_check{$opt}
+                or defined $plugin_valid_check{$opt};
+        }
     }
-    # Remaining arguments are things to check
+
+    # Remaining arguments are things to check. So why aren't I
+    # capturing them or something? I don't know.
 
     return \&do_lint;
 }
@@ -497,13 +737,14 @@ sub register_plugin {
     my ( undef, $plugin, $new_checks ) = @_;
 
     # Register the plugin
-    for my $check ( @$new_checks ) {
+    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.";
+            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;
     }
index d27b2ce..05d53d8 100644 (file)
@@ -1,36 +1,48 @@
 #!./perl -w
 
 BEGIN {
-    if ($ENV{PERL_CORE}){
-       chdir('t') if -d 't';
-       @INC = ('.', '../lib');
-    } else {
-       unshift @INC, 't';
-       push @INC, "../../t";
+    if ( $ENV{PERL_CORE} ) {
+        chdir('t') if -d 't';
+        @INC = ( '.', '../lib' );
+    }
+    else {
+        unshift @INC, 't';
+        push @INC, "../../t";
     }
     require Config;
-    if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+    if ( ( $Config::Config{'extensions'} !~ /\bB\b/ ) ) {
         print "1..0 # Skip -- Perl configured without B module\n";
         exit 0;
     }
     require 'test.pl';
 }
 
-plan tests => 24; # adjust also number of skipped tests !
+plan tests => 28;
 
 # Runs a separate perl interpreter with the appropriate lint options
 # turned on
 sub runlint ($$$;$) {
-    my ($opts,$prog,$result,$testname) = @_;
+    my ( $opts, $prog, $result, $testname ) = @_;
     my $res = runperl(
-       switches => [ "-MO=Lint,$opts" ],
-       prog     => $prog,
-       stderr   => 1,
+        switches => ["-MO=Lint,$opts"],
+        prog     => $prog,
+        stderr   => 1,
     );
     $res =~ s/-e syntax OK\n$//;
     is( $res, $result, $testname || $opts );
 }
 
+runlint 'magic-diamond', 'while(<>){}', <<'RESULT';
+Use of <> at -e line 1
+RESULT
+
+runlint 'magic-diamond', 'while(<ARGV>){}', <<'RESULT';
+Use of <> at -e line 1
+RESULT
+
+runlint 'magic-diamond', 'while(<FOO>){}', <<'RESULT';
+RESULT
+
 runlint 'context', '$foo = @bar', <<'RESULT';
 Implicit scalar context for array in scalar assignment at -e line 1
 RESULT
@@ -57,67 +69,66 @@ 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,
+        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' );
 }
 
-SKIP : {
-
-    use Config;
-    skip("Doesn't work with threaded perls",15)
-       if $Config{useithreads} || ($] < 5.009 && $Config{use5005threads});
-
-    runlint 'implicit-read', 'for ( @ARGV ) { 1 }', <<'RESULT', 'implicit-read in foreach';
+runlint 'implicit-read', 'for ( @ARGV ) { 1 }',
+    <<'RESULT', 'implicit-read in foreach';
 Implicit use of $_ in foreach at -e line 1
 RESULT
 
-    runlint 'implicit-read', '1 for @ARGV', '', 'implicit-read in foreach';
+runlint 'implicit-read', '1 for @ARGV', '', 'implicit-read in foreach';
 
-    runlint 'dollar-underscore', '$_ = 1', <<'RESULT';
+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', 'foo( $_ ) for @A',      '';
+runlint 'dollar-underscore', 'map { foo( $_ ) } @A',  '';
+runlint 'dollar-underscore', 'grep { foo( $_ ) } @A', '';
 
-    runlint 'dollar-underscore', 'print', <<'RESULT', 'dollar-underscore in print';
+runlint 'dollar-underscore', 'print',
+    <<'RESULT', 'dollar-underscore in print';
 Use of $_ at -e line 1
 RESULT
 
-    runlint 'private-names', 'sub A::_f{};A::_f()', <<'RESULT';
-Illegal reference to private name _f at -e line 1
+runlint 'private-names', 'sub A::_f{};A::_f()', <<'RESULT';
+Illegal reference to private name '_f' at -e line 1
 RESULT
 
-    runlint 'private-names', '$A::_x', <<'RESULT';
-Illegal reference to private name _x at -e line 1
+runlint 'private-names', '$A::_x', <<'RESULT';
+Illegal reference to private name '_x' at -e line 1
 RESULT
 
-    runlint 'private-names', 'sub A::_f{};A->_f()', <<'RESULT',
-Illegal reference to private method name _f at -e line 1
+runlint 'private-names', 'sub A::_f{};A->_f()', <<'RESULT',
+Illegal reference to private method name '_f' at -e line 1
 RESULT
     'private-names (method)';
 
-    runlint 'undefined-subs', 'foo()', <<'RESULT';
-Undefined subroutine foo called at -e line 1
+runlint 'undefined-subs', 'foo()', <<'RESULT';
+Nonexistant subroutine 'foo' called at -e line 1
+RESULT
+
+runlint 'undefined-subs', 'foo();sub foo;', <<'RESULT';
+Undefined subroutine 'foo' called at -e line 1
 RESULT
 
-    runlint 'regexp-variables', 'print $&', <<'RESULT';
+runlint 'regexp-variables', 'print $&', <<'RESULT';
 Use of regexp variable $& at -e line 1
 RESULT
 
-    runlint 'regexp-variables', 's/./$&/', <<'RESULT';
+runlint 'regexp-variables', 's/./$&/', <<'RESULT';
 Use of regexp variable $& at -e line 1
 RESULT
 
-    runlint 'bare-subs', 'sub bare(){1};$x=bare', '';
+runlint 'bare-subs', 'sub bare(){1};$x=bare', '';
 
-    runlint 'bare-subs', 'sub bare(){1}; $x=[bare=>0]; $x=$y{bare}', <<'RESULT';
+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
-
-}