From: Joshua ben Jore Date: Thu, 18 May 2006 08:45:30 +0000 (-0500) Subject: Re: B::Lint changes X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9b494a7e378ba156401fa90333424582b0fcf907;p=p5sagit%2Fp5-mst-13.2.git Re: B::Lint changes From: "Joshua ben Jore" Message-ID: p4raw-id: //depot/perl@28338 --- diff --git a/ext/B/B/Lint.pm b/ext/B/B/Lint.pm index ebd0a7a..e57471b 100644 --- a/ext/B/B/Lint.pm +++ b/ext/B/B/Lint.pm @@ -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 + +Produces a warning whenever the magic CE> 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. When perl opens it with +CE> it actually executes the shell program C. This +makes CE> dangerous to use carelessly. + =item B 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() 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 or C, 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 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. + 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< ...>> but warn on C< ...>> + # 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; } diff --git a/ext/B/t/lint.t b/ext/B/t/lint.t index d27b2ce..05d53d8 100644 --- a/ext/B/t/lint.t +++ b/ext/B/t/lint.t @@ -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(){}', <<'RESULT'; +Use of <> at -e line 1 +RESULT + +runlint 'magic-diamond', 'while(){}', <<'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 - -}