package B::Lint;
-our $VERSION = '1.06';
+our $VERSION = '1.08';
=head1 NAME
=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
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.
=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
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;
}
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;
}
#!./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
{
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
-
-}
projects / p5sagit/p5-mst-13.2.git / commitdiff