B-Lint-1.17/000755 000766 000766 00000000000 12100772134 012502 5ustar00rjbsrjbs000000 000000 B-Lint-1.17/Changes000644 000766 000766 00000001775 12100772067 014014 0ustar00rjbsrjbs000000 000000 Revision history for B-Lint 1.17 2013-0126 make the use of "deprecate" conditional 1.16 2013-01-23 install to sitelib, not corelib on 5.12.0 and later 1.15 2013-01-23 Merge changes from perl core: - Stop the indexer from processing private modules Add warning that B::Lint will be removed from core, if used from core 1.13 2011-07-09 Merge changes from perl core: - Fix typos 1.12 2010-07-10 Require Perl 5.6.0 or later (Closes RT#52492) Fix spelling error in a warning (Closes RT#56089) Merge changes from perl core: - Fix a pod error - Adjust to new core module layout - Enable strictures and warnings for tests - Improve diagnostic for test failures - Add a VERSION to B::Lint::Debug 1.11 2007-10-08 Giving credit is important. 1.10 2007-10-08 Installs over core B::Lint. 1.09 2007-02-07 First version that's separate from bleadperl B-Lint-1.17/lib/000755 000766 000766 00000000000 12100772134 013250 5ustar00rjbsrjbs000000 000000 B-Lint-1.17/Makefile.PL000644 000766 000766 00000001305 12100354530 014447 0ustar00rjbsrjbs000000 000000 require 5.006000; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'B::Lint', AUTHOR => 'Joshua ben Jore ', VERSION_FROM => 'lib/B/Lint.pm', ABSTRACT_FROM => 'lib/B/Lint.pm', PREREQ_PM => { 'Test::More' => 0, 'Module::Pluggable' => 0, 'if' => 0 }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'B-Lint-*' }, # B::Lint is a dual-life module. Must install over core for pre-5.12 perls. INSTALLDIRS => $] < 5.012 ? 'perl' : 'site', PM => { 'lib/B/Lint.pm' => '$(INST_ARCHLIB)/B/Lint.pm', 'lib/B/Lint/Debug.pm' => '$(INST_ARCHLIB)/B/Lint/Debug.pm', }, ); B-Lint-1.17/MANIFEST000644 000766 000766 00000000423 12100772134 013632 0ustar00rjbsrjbs000000 000000 Changes lib/B/Lint.pm lib/B/Lint/Debug.pm Makefile.PL MANIFEST This list of files META.yml Module meta-data (added by MakeMaker) README t/lint.t t/pluglib/B/Lint/Plugin/Test.pm t/test.pl META.json Module JSON meta-data (added by MakeMaker) B-Lint-1.17/META.json000644 000766 000766 00000001623 12100772134 014125 0ustar00rjbsrjbs000000 000000 { "abstract" : "Perl lint", "author" : [ "Joshua ben Jore " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.64, CPAN::Meta::Converter version 2.120921", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "B-Lint", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Module::Pluggable" : "0", "Test::More" : "0", "if" : "0" } } }, "release_status" : "stable", "version" : "1.17" } B-Lint-1.17/META.yml000644 000766 000766 00000000761 12100772134 013757 0ustar00rjbsrjbs000000 000000 --- abstract: 'Perl lint' author: - 'Joshua ben Jore ' build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.64, CPAN::Meta::Converter version 2.120921' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: B-Lint no_index: directory: - t - inc requires: Module::Pluggable: 0 Test::More: 0 if: 0 version: 1.17 B-Lint-1.17/README000644 000766 000766 00000002530 12100106775 013364 0ustar00rjbsrjbs000000 000000 B-Lint The README is used to introduce the module and provide instructions on how to install the module, any machine dependencies it may have (for example C compilers and installed libraries) and any other information that should be provided before the module is installed. A README file is required for CPAN modules since CPAN extracts the README file from a module distribution so that people browsing the archive can use it get an idea of the modules uses. It is usually a good idea to provide version information here so that people can decide whether fixes for the module are worth downloading. INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc B::Lint You can also look for information at: Search CPAN http://search.cpan.org/dist/B-Lint CPAN Request Tracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=B-Lint AnnoCPAN, annotated CPAN documentation: http://annocpan.org/dist/B-Lint CPAN Ratings: http://cpanratings.perl.org/d/B-Lint COPYRIGHT AND LICENCE Copyright (C) 2007 Joshua ben Jore This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. B-Lint-1.17/t/000755 000766 000766 00000000000 12100772134 012745 5ustar00rjbsrjbs000000 000000 B-Lint-1.17/t/lint.t000644 000766 000766 00000007433 12100107201 014072 0ustar00rjbsrjbs000000 000000 #!./perl -w BEGIN { unshift @INC, 't'; push @INC, "../../t"; require Config; if ( ( $Config::Config{'extensions'} !~ /\bB\b/ ) ) { print "1..0 # Skip -- Perl configured without B module\n"; exit 0; } require 'test.pl'; } use strict; use warnings; plan tests => 29; # Runs a separate perl interpreter with the appropriate lint options # turned on sub runlint ($$$;$) { my ( $opts, $prog, $result, $testname ) = @_; my $res = runperl( switches => ["-MO=Lint,$opts"], prog => $prog, stderr => 1, ); $res =~ s/-e syntax OK\n$//; local $::Level = $::Level + 1; 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 runlint 'context', '$foo = length @bar', <<'RESULT'; Implicit scalar context for array in length at -e line 1 RESULT runlint 'context', 'our @bar', ''; runlint 'context', 'exists $BAR{BAZ}', ''; runlint 'implicit-read', '/foo/', <<'RESULT'; Implicit match on $_ at -e line 1 RESULT runlint 'implicit-read', 'grep /foo/, ()', ''; runlint 'implicit-read', 'grep { /foo/ } ()', ''; runlint 'implicit-write', 's/foo/bar/', <<'RESULT'; Implicit substitution on $_ at -e line 1 RESULT 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 'dollar-underscore', '$_ = 1', <<'RESULT'; Use of $_ at -e line 1 RESULT 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'; 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 RESULT 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 RESULT 'private-names (method)'; runlint 'undefined-subs', 'foo()', <<'RESULT'; Nonexistent 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'; Use of regexp variable $& at -e line 1 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=>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 => [ '-It/pluglib', '-MO=Lint,none' ], prog => 1, stderr => 1, ); like( $res, qr/Module::Pluggable ok\./, 'Lint uses Module::Pluggable' ); } B-Lint-1.17/t/pluglib/000755 000766 000766 00000000000 12100772134 014403 5ustar00rjbsrjbs000000 000000 B-Lint-1.17/t/test.pl000644 000766 000766 00000047232 12100107463 014266 0ustar00rjbsrjbs000000 000000 # # t/test.pl - most of Test::More functionality without the fuss # NOTE: # # Increment ($x++) has a certain amount of cleverness for things like # # $x = 'zz'; # $x++; # $x eq 'aaa'; # # stands more chance of breaking than just a simple # # $x = $x + 1 # # In this file, we use the latter "Baby Perl" approach, and increment # will be worked over by t/op/inc.t $Level = 1; my $test = 1; my $planned; my $noplan; $TODO = 0; $NO_ENDING = 0; sub plan { my $n; if (@_ == 1) { $n = shift; if ($n eq 'no_plan') { undef $n; $noplan = 1; } } else { my %plan = @_; $n = $plan{tests}; } print STDOUT "1..$n\n" unless $noplan; $planned = $n; } END { my $ran = $test - 1; if (!$NO_ENDING) { if (defined $planned && $planned != $ran) { print STDERR "# Looks like you planned $planned tests but ran $ran.\n"; } elsif ($noplan) { print "1..$ran\n"; } } } # Use this instead of "print STDERR" when outputing failure diagnostic # messages sub _diag { return unless @_; my @mess = map { /^#/ ? "$_\n" : "# $_\n" } map { split /\n/ } @_; my $fh = $TODO ? *STDOUT : *STDERR; print $fh @mess; } sub diag { _diag(@_); } sub skip_all { if (@_) { print STDOUT "1..0 # Skipped: @_\n"; } else { print STDOUT "1..0\n"; } exit(0); } sub _ok { my ($pass, $where, $name, @mess) = @_; # Do not try to microoptimize by factoring out the "not ". # VMS will avenge. my $out; if ($name) { # escape out '#' or it will interfere with '# skip' and such $name =~ s/#/\\#/g; $out = $pass ? "ok $test - $name" : "not ok $test - $name"; } else { $out = $pass ? "ok $test" : "not ok $test"; } $out .= " # TODO $TODO" if $TODO; print STDOUT "$out\n"; unless ($pass) { _diag "# Failed $where\n"; } # Ensure that the message is properly escaped. _diag @mess; $test = $test + 1; # don't use ++ return $pass; } sub _where { my @caller = caller($Level); return "at $caller[1] line $caller[2]"; } # DON'T use this for matches. Use like() instead. sub ok ($@) { my ($pass, $name, @mess) = @_; _ok($pass, _where(), $name, @mess); } sub _q { my $x = shift; return 'undef' unless defined $x; my $q = $x; $q =~ s/\\/\\\\/g; $q =~ s/'/\\'/g; return "'$q'"; } sub _qq { my $x = shift; return defined $x ? '"' . display ($x) . '"' : 'undef'; }; # keys are the codes \n etc map to, values are 2 char strings such as \n my %backslash_escape; foreach my $x (split //, 'nrtfa\\\'"') { $backslash_escape{ord eval "\"\\$x\""} = "\\$x"; } # A way to display scalars containing control characters and Unicode. # Trying to avoid setting $_, or relying on local $_ to work. sub display { my @result; foreach my $x (@_) { if (defined $x and not ref $x) { my $y = ''; foreach my $c (unpack("U*", $x)) { if ($c > 255) { $y .= sprintf "\\x{%x}", $c; } elsif ($backslash_escape{$c}) { $y .= $backslash_escape{$c}; } else { my $z = chr $c; # Maybe we can get away with a literal... $z = sprintf "\\%03o", $c if $z =~ /[[:^print:]]/; $y .= $z; } } $x = $y; } return $x unless wantarray; push @result, $x; } return @result; } sub is ($$@) { my ($got, $expected, $name, @mess) = @_; my $pass; if( !defined $got || !defined $expected ) { # undef only matches undef $pass = !defined $got && !defined $expected; } else { $pass = $got eq $expected; } unless ($pass) { unshift(@mess, "# got "._q($got)."\n", "# expected "._q($expected)."\n"); } _ok($pass, _where(), $name, @mess); } sub isnt ($$@) { my ($got, $isnt, $name, @mess) = @_; my $pass; if( !defined $got || !defined $isnt ) { # undef only matches undef $pass = defined $got || defined $isnt; } else { $pass = $got ne $isnt; } unless( $pass ) { unshift(@mess, "# it should not be "._q($got)."\n", "# but it is.\n"); } _ok($pass, _where(), $name, @mess); } sub cmp_ok ($$$@) { my($got, $type, $expected, $name, @mess) = @_; my $pass; { local $^W = 0; local($@,$!); # don't interfere with $@ # eval() sometimes resets $! $pass = eval "\$got $type \$expected"; } unless ($pass) { # It seems Irix long doubles can have 2147483648 and 2147483648 # that stringify to the same thing but are acutally numerically # different. Display the numbers if $type isn't a string operator, # and the numbers are stringwise the same. # (all string operators have alphabetic names, so tr/a-z// is true) # This will also show numbers for some uneeded cases, but will # definately be helpful for things such as == and <= that fail if ($got eq $expected and $type !~ tr/a-z//) { unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; } unshift(@mess, "# got "._q($got)."\n", "# expected $type "._q($expected)."\n"); } _ok($pass, _where(), $name, @mess); } # Check that $got is within $range of $expected # if $range is 0, then check it's exact # else if $expected is 0, then $range is an absolute value # otherwise $range is a fractional error. # Here $range must be numeric, >= 0 # Non numeric ranges might be a useful future extension. (eg %) sub within ($$$@) { my ($got, $expected, $range, $name, @mess) = @_; my $pass; if (!defined $got or !defined $expected or !defined $range) { # This is a fail, but doesn't need extra diagnostics } elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) { # This is a fail unshift @mess, "# got, expected and range must be numeric\n"; } elsif ($range < 0) { # This is also a fail unshift @mess, "# range must not be negative\n"; } elsif ($range == 0) { # Within 0 is == $pass = $got == $expected; } elsif ($expected == 0) { # If expected is 0, treat range as absolute $pass = ($got <= $range) && ($got >= - $range); } else { my $diff = $got - $expected; $pass = abs ($diff / $expected) < $range; } unless ($pass) { if ($got eq $expected) { unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; } unshift@mess, "# got "._q($got)."\n", "# expected "._q($expected)." (within "._q($range).")\n"; } _ok($pass, _where(), $name, @mess); } # Note: this isn't quite as fancy as Test::More::like(). sub like ($$@) { like_yn (0,@_) }; # 0 for - sub unlike ($$@) { like_yn (1,@_) }; # 1 for un- sub like_yn ($$$@) { my ($flip, $got, $expected, $name, @mess) = @_; my $pass; $pass = $got =~ /$expected/ if !$flip; $pass = $got !~ /$expected/ if $flip; unless ($pass) { unshift(@mess, "# got '$got'\n", "# expected /$expected/\n"); } local $Level = $Level + 1; _ok($pass, _where(), $name, @mess); } sub pass { _ok(1, '', @_); } sub fail { _ok(0, _where(), @_); } sub curr_test { $test = shift if @_; return $test; } sub next_test { my $retval = $test; $test = $test + 1; # don't use ++ $retval; } # Note: can't pass multipart messages since we try to # be compatible with Test::More::skip(). sub skip { my $why = shift; my $n = @_ ? shift : 1; for (1..$n) { print STDOUT "ok $test # skip: $why\n"; $test = $test + 1; } local $^W = 0; last SKIP; } sub todo_skip { my $why = shift; my $n = @_ ? shift : 1; for (1..$n) { print STDOUT "not ok $test # TODO & SKIP: $why\n"; $test = $test + 1; } local $^W = 0; last TODO; } sub eq_array { my ($ra, $rb) = @_; return 0 unless $#$ra == $#$rb; for my $i (0..$#$ra) { next if !defined $ra->[$i] && !defined $rb->[$i]; return 0 if !defined $ra->[$i]; return 0 if !defined $rb->[$i]; return 0 unless $ra->[$i] eq $rb->[$i]; } return 1; } sub eq_hash { my ($orig, $suspect) = @_; my $fail; while (my ($key, $value) = each %$suspect) { # Force a hash recompute if this perl's internals can cache the hash key. $key = "" . $key; if (exists $orig->{$key}) { if ($orig->{$key} ne $value) { print STDOUT "# key ", _qq($key), " was ", _qq($orig->{$key}), " now ", _qq($value), "\n"; $fail = 1; } } else { print STDOUT "# key ", _qq($key), " is ", _qq($value), ", not in original.\n"; $fail = 1; } } foreach (keys %$orig) { # Force a hash recompute if this perl's internals can cache the hash key. $_ = "" . $_; next if (exists $suspect->{$_}); print STDOUT "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; $fail = 1; } !$fail; } sub require_ok ($) { my ($require) = @_; eval < [ command-line switches ] # nolib => 1 # don't use -I../lib (included by default) # prog => one-liner (avoid quotes) # progs => [ multi-liner (avoid quotes) ] # progfile => perl script # stdin => string to feed the stdin # stderr => redirect stderr to stdout # args => [ command-line arguments to the perl program ] # verbose => print the command line my $is_mswin = $^O eq 'MSWin32'; my $is_netware = $^O eq 'NetWare'; my $is_macos = $^O eq 'MacOS'; my $is_vms = $^O eq 'VMS'; sub _quote_args { my ($runperl, $args) = @_; foreach (@$args) { # In VMS protect with doublequotes because otherwise # DCL will lowercase -- unless already doublequoted. $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0; $$runperl .= ' ' . $_; } } sub _create_runperl { # Create the string to qx in runperl(). my %args = @_; my $runperl = $^X =~ m/\s/ ? qq{"$^X"} : $^X; #- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind if ($ENV{PERL_RUNPERL_DEBUG}) { $runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl"; } unless ($args{nolib}) { if ($is_macos) { $runperl .= ' -I::lib'; # Use UNIX style error messages instead of MPW style. $runperl .= ' -MMac::err=unix' if $args{stderr}; } else { $runperl .= ' "-I../lib"'; # doublequotes because of VMS } } if ($args{switches}) { local $Level = 2; die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where() unless ref $args{switches} eq "ARRAY"; _quote_args(\$runperl, $args{switches}); } if (defined $args{prog}) { die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where() if defined $args{progs}; $args{progs} = [$args{prog}] } if (defined $args{progs}) { die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where() unless ref $args{progs} eq "ARRAY"; foreach my $prog (@{$args{progs}}) { if ($is_mswin || $is_netware || $is_vms) { $runperl .= qq ( -e "$prog" ); } else { $runperl .= qq ( -e '$prog' ); } } } elsif (defined $args{progfile}) { $runperl .= qq( "$args{progfile}"); } else { # You probaby didn't want to be sucking in from the upstream stdin die "test.pl:runperl(): none of prog, progs, progfile, args, " . " switches or stdin specified" unless defined $args{args} or defined $args{switches} or defined $args{stdin}; } if (defined $args{stdin}) { # so we don't try to put literal newlines and crs onto the # command line. $args{stdin} =~ s/\n/\\n/g; $args{stdin} =~ s/\r/\\r/g; if ($is_mswin || $is_netware || $is_vms) { $runperl = qq{$^X -e "print qq(} . $args{stdin} . q{)" | } . $runperl; } elsif ($is_macos) { # MacOS can only do two processes under MPW at once; # the test itself is one; we can't do two more, so # write to temp file my $stdin = qq{$^X -e 'print qq(} . $args{stdin} . qq{)' > teststdin; }; if ($args{verbose}) { my $stdindisplay = $stdin; $stdindisplay =~ s/\n/\n\#/g; print STDERR "# $stdindisplay\n"; } `$stdin`; $runperl .= q{ < teststdin }; } else { $runperl = qq{$^X -e 'print qq(} . $args{stdin} . q{)' | } . $runperl; } } if (defined $args{args}) { _quote_args(\$runperl, $args{args}); } $runperl .= ' 2>&1' if $args{stderr} && !$is_macos; $runperl .= " \xB3 Dev:Null" if !$args{stderr} && $is_macos; if ($args{verbose}) { my $runperldisplay = $runperl; $runperldisplay =~ s/\n/\n\#/g; print STDERR "# $runperldisplay\n"; } return $runperl; } sub runperl { die "test.pl:runperl() does not take a hashref" if ref $_[0] and ref $_[0] eq 'HASH'; my $runperl = &_create_runperl; my $result; my $tainted = ${^TAINT}; my %args = @_; exists $args{switches} && grep m/^-T$/, @{$args{switches}} and $tainted = $tainted + 1; if ($tainted) { # We will assume that if you're running under -T, you really mean to # run a fresh perl, so we'll brute force launder everything for you my $sep; eval "require Config; Config->import"; if ($@) { warn "test.pl had problems loading Config: $@"; $sep = ':'; } else { $sep = $Config{path_sep}; } my @keys = grep {exists $ENV{$_}} qw(CDPATH IFS ENV BASH_ENV); local @ENV{@keys} = (); # Untaint, plus take out . and empty string: local $ENV{'DCL$PATH'} = $1 if $is_vms && ($ENV{'DCL$PATH'} =~ /(.*)/s); $ENV{PATH} =~ /(.*)/s; local $ENV{PATH} = join $sep, grep { $_ ne "" and $_ ne "." and ($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) } split quotemeta ($sep), $1; $runperl =~ /(.*)/s; $runperl = $1; $result = `$runperl`; } else { $result = `$runperl`; } $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these return $result; } *run_perl = \&runperl; # Nice alias. sub DIE { print STDERR "# @_\n"; exit 1; } # A somewhat safer version of the sometimes wrong $^X. my $Perl; sub which_perl { unless (defined $Perl) { $Perl = $^X; # VMS should have 'perl' aliased properly return $Perl if $^O eq 'VMS'; my $exe; eval "require Config; Config->import"; if ($@) { warn "test.pl had problems loading Config: $@"; $exe = ''; } else { $exe = $Config{_exe}; } $exe = '' unless defined $exe; # This doesn't absolutize the path: beware of future chdirs(). # We could do File::Spec->abs2rel() but that does getcwd()s, # which is a bit heavyweight to do here. if ($Perl =~ /^perl\Q$exe\E$/i) { my $perl = "perl$exe"; eval "require File::Spec"; if ($@) { warn "test.pl had problems loading File::Spec: $@"; $Perl = "./$perl"; } else { $Perl = File::Spec->catfile(File::Spec->curdir(), $perl); } } # Build up the name of the executable file from the name of # the command. if ($Perl !~ /\Q$exe\E$/i) { $Perl .= $exe; } warn "which_perl: cannot find $Perl from $^X" unless -f $Perl; # For subcommands to use. $ENV{PERLEXE} = $Perl; } return $Perl; } sub unlink_all { foreach my $file (@_) { 1 while unlink $file; print STDERR "# Couldn't unlink '$file': $!\n" if -f $file; } } my $tmpfile = "misctmp000"; 1 while -f ++$tmpfile; END { unlink_all $tmpfile } # # _fresh_perl # # The $resolve must be a subref that tests the first argument # for success, or returns the definition of success (e.g. the # expected scalar) if given no arguments. # sub _fresh_perl { my($prog, $resolve, $runperl_args, $name) = @_; $runperl_args ||= {}; $runperl_args->{progfile} = $tmpfile; $runperl_args->{stderr} = 1; open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; # VMS adjustments if( $^O eq 'VMS' ) { $prog =~ s#/dev/null#NL:#; # VMS file locking $prog =~ s{if \(-e _ and -f _ and -r _\)} {if (-e _ and -f _)} } print TEST $prog; close TEST or die "Cannot close $tmpfile: $!"; my $results = runperl(%$runperl_args); my $status = $?; # Clean up the results into something a bit more predictable. $results =~ s/\n+$//; $results =~ s/at\s+misctmp\d+\s+line/at - line/g; $results =~ s/of\s+misctmp\d+\s+aborted/of - aborted/g; # bison says 'parse error' instead of 'syntax error', # various yaccs may or may not capitalize 'syntax'. $results =~ s/^(syntax|parse) error/syntax error/mig; if ($^O eq 'VMS') { # some tests will trigger VMS messages that won't be expected $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; # pipes double these sometimes $results =~ s/\n\n/\n/g; } my $pass = $resolve->($results); unless ($pass) { _diag "# PROG: \n$prog\n"; _diag "# EXPECTED:\n", $resolve->(), "\n"; _diag "# GOT:\n$results\n"; _diag "# STATUS: $status\n"; } # Use the first line of the program as a name if none was given unless( $name ) { ($first_line, $name) = $prog =~ /^((.{1,50}).*)/; $name .= '...' if length $first_line > length $name; } _ok($pass, _where(), "fresh_perl - $name"); } # # fresh_perl_is # # Combination of run_perl() and is(). # sub fresh_perl_is { my($prog, $expected, $runperl_args, $name) = @_; local $Level = 2; _fresh_perl($prog, sub { @_ ? $_[0] eq $expected : $expected }, $runperl_args, $name); } # # fresh_perl_like # # Combination of run_perl() and like(). # sub fresh_perl_like { my($prog, $expected, $runperl_args, $name) = @_; local $Level = 2; _fresh_perl($prog, sub { @_ ? $_[0] =~ (ref $expected ? $expected : /$expected/) : $expected }, $runperl_args, $name); } sub can_ok ($@) { my($proto, @methods) = @_; my $class = ref $proto || $proto; unless( @methods ) { return _ok( 0, _where(), "$class->can(...)" ); } my @nok = (); foreach my $method (@methods) { local($!, $@); # don't interfere with caller's $@ # eval sometimes resets $! eval { $proto->can($method) } || push @nok, $method; } my $name; $name = @methods == 1 ? "$class->can('$methods[0]')" : "$class->can(...)"; _ok( !@nok, _where(), $name ); } sub isa_ok ($$;$) { my($object, $class, $obj_name) = @_; my $diag; $obj_name = 'The object' unless defined $obj_name; my $name = "$obj_name isa $class"; if( !defined $object ) { $diag = "$obj_name isn't defined"; } elsif( !ref $object ) { $diag = "$obj_name isn't a reference"; } else { # We can't use UNIVERSAL::isa because we want to honor isa() overrides local($@, $!); # eval sometimes resets $! my $rslt = eval { $object->isa($class) }; if( $@ ) { if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { if( !UNIVERSAL::isa($object, $class) ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } else { die <isa on your object and got some weird error. This should never happen. Please contact the author immediately. Here's the error. $@ WHOA } } elsif( !$rslt ) { my $ref = ref $object; $diag = "$obj_name isn't a '$class' it's a '$ref'"; } } _ok( !$diag, _where(), $name ); } 1; B-Lint-1.17/t/pluglib/B/000755 000766 000766 00000000000 12100772134 014564 5ustar00rjbsrjbs000000 000000 B-Lint-1.17/t/pluglib/B/Lint/000755 000766 000766 00000000000 12100772134 015472 5ustar00rjbsrjbs000000 000000 B-Lint-1.17/t/pluglib/B/Lint/Plugin/000755 000766 000766 00000000000 12100772134 016730 5ustar00rjbsrjbs000000 000000 B-Lint-1.17/t/pluglib/B/Lint/Plugin/Test.pm000644 000766 000766 00000000610 12100107201 020165 0ustar00rjbsrjbs000000 000000 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; B-Lint-1.17/lib/B/000755 000766 000766 00000000000 12100772134 013431 5ustar00rjbsrjbs000000 000000 B-Lint-1.17/lib/B/Lint/000755 000766 000766 00000000000 12100772134 014337 5ustar00rjbsrjbs000000 000000 B-Lint-1.17/lib/B/Lint.pm000644 000766 000766 00000052207 12100772111 014676 0ustar00rjbsrjbs000000 000000 package B::Lint; use if $] > 5.017, 'deprecate'; our $VERSION = '1.17'; ## no critic =head1 NAME B::Lint - Perl lint =head1 SYNOPSIS perl -MO=Lint[,OPTIONS] foo.pl =head1 DESCRIPTION The B::Lint module is equivalent to an extended version of the B<-w> option of B. It is named after the program F which carries out a similar process for C programs. =head1 OPTIONS AND LINT CHECKS Option words are separated by commas (not whitespace) and follow the usual conventions of compiler backend options. Following any options (indicated by a leading B<->) come lint check arguments. Each such argument (apart from the special B and B options) is a word representing one possible lint check (turning on that check) or is B (turning off that check). Before processing the check arguments, a standard list of checks is turned on. Later options 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 context. For example, both of the lines $foo = length(@bar); $foo = @bar; will elicit a warning. Using an explicit B silences the warning. For example, $foo = scalar(@bar); =item B and B These options produce a warning whenever an operation implicitly reads or (respectively) writes to one of Perl's special variables. For example, B will warn about these: /foo/; and B will warn about these: s/foo/bar/; Both B and B warn about this: for (@a) { ... } =item B This option warns whenever a bareword is implicitly quoted, but is also the name of a subroutine in the current package. Typical mistakes that it will trap are: use constant foo => 'bar'; @a = ( foo => 1 ); $b{foo} = 2; Neither of these will do what a naive user would expect. =item B This option warns whenever C<$_> is used either explicitly anywhere or as the implicit argument of a B statement. =item B This option warns on each use of any variable, subroutine or method name that lives in a non-current package but begins with an underscore ("_"). Warnings aren't issued for the special case of the single character name "_" by itself (e.g. C<$_> and C<@_>). =item B This option warns whenever an undefined subroutine is invoked. This option will only catch explicitly invoked subroutines such as C and not indirect invocations such as C<&$subref()> or C<$obj-Emeth()>. Note that some programs or modules delay definition of subs until runtime by means of the AUTOLOAD mechanism. =item B This option warns whenever one of the regexp variables C<$`>, C<$&> or C<$'> is used. Any occurrence of any of these variables in your program can slow your whole program down. See L for details. =item B Turn all warnings on. =item B Turn all warnings off. =back =head1 NON LINT-CHECK OPTIONS =over 8 =item B<-u Package> Normally, Lint only checks the main code of the program together with all subs defined in package main. The B<-u> option lets you include other package names whose subs are then checked by Lint. =back =head1 EXTENDING LINT 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 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. The class methods C<< B::Lint->file >> and C<< B::Lint->line >> contain the current filename and line number. package Sample; use B::Lint; B::Lint->register_plugin( Sample => [ 'good_taste' ] ); sub match { 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 =back =head1 BUGS This is only a very preliminary version. =head1 AUTHOR Malcolm Beattie, mbeattie@sable.ox.ac.uk. =head1 ACKNOWLEDGEMENTS Sebastien Aperghis-Tramoni - bug fixes =cut use strict; 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 ( any { $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 curstash {$curstash} sub curcv {$curcv} # Lint checks my %check; my %implies_ok_context; 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 magic_diamond undefined_subs regexp_variables); my %valid_check; # All valid checks 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 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. sub warning { my $format = ( @_ < 2 ) ? "%s" : shift @_; warn sprintf( "$format at %s line %d\n", @_, $file, $line ); return undef; ## no critic undef } # This gimme can't cope with context that's only determined # at runtime via dowantarray(). sub gimme { my $op = shift @_; my $flags = $op->flags; if ( $flags & OPf_WANT ) { return ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ? 1 : 0 ); } return undef; ## no critic undef } 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. 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. 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 critic strict no strict 'refs'; \*$subname; }; *$target = sub { my ($op) = @_; my $elt; if ( not $op->isa('B::PADOP') ) { $elt = $op->$attr; } 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) = first { eval { $_->isa('B::SV') } ? $_ : (); } @elts[ 0, reverse 1 .. $#elts ]; return $elt; }; } sub B::OP::lint { 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; return; } sub B::COP::lint { 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; return; } sub B::UNOP::lint { my ($op) = @_; my $opname = $op->name; 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; } 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; return; } sub B::PMOP::lint { 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 $_'; } 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; return; } sub B::LOOP::lint { 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; return; } # 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::PADOP::lint = \&B::SVOP::lint; sub B::SVOP::lint { 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 <>'; } 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; } } DOLLAR_UNDERSCORE: { # Warn on uses of $_ with a few exceptions. I'm not warning on # $_ inside grep, map, or statement modifier 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 $_'; } 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; } 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'; ## no critic strict if ( not exists &$subname ) { $subname =~ s/\Amain:://; warning q[Nonexistent 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; return; } sub B::GV::lintcv { # Example: B::svref_2object( \ *A::Glob )->lintcv my $gv = shift @_; my $cv = $gv->CV; return unless $cv->can('lintcv'); $cv->lintcv; return; } sub B::CV::lintcv { # Example: B::svref_2object( \ &foo )->lintcv # Write to the *global* $ $curcv = shift @_; #warn sprintf("lintcv: %s::%s (done=%d)\n", # $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; return; } sub do_lint { my %search_pack; # 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 eval { $av->isa('B::AV') }; for my $cv ( $av->ARRAY ) { next unless ref($cv) and $cv->FILE eq $0; $cv->lintcv; } } walksymtable( \%main::, sub { if ( $_[0]->FILE eq $0 ) { $_[0]->lintcv } }, sub {1} ); return; } sub compile { my @options = @_; # Turn on default lint checks for my $opt (@default_checks) { $check{$opt} = 1; } 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 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 my $opt ( @default_checks, @options ) { $opt =~ tr/-/_/; if ( $opt eq "all" ) { %check = %valid_check; } elsif ( $opt eq "none" ) { %check = (); } else { if ( $opt =~ s/\Ano_//xms ) { $check{$opt} = 0; } else { $check{$opt} = 1; } carp "No such check: $opt" unless defined $valid_check{$opt}; } } # Remaining arguments are things to check. So why aren't I # capturing them or something? I don't know. return \&do_lint; } sub register_plugin { my ( undef, $plugin, $new_checks ) = @_; # 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; } # 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; } 1; B-Lint-1.17/lib/B/Lint/Debug.pm000644 000766 000766 00000003053 12100772114 015722 0ustar00rjbsrjbs000000 000000 package B::Lint::Debug; use if $] > 5.017, 'deprecate'; our $VERSION = '1.17'; =head1 NAME B::Lint::Debug - Adds debugging stringification to B:: =head1 DESCRIPTION This module injects stringification to a B::OP*/B::SPECIAL. This should not be loaded unless you're debugging. =cut package # hide from PAUSE B::SPECIAL; use overload '""' => sub { my $self = shift @_; "SPECIAL($$self)"; }; package # hide from PAUSE B::OP; use overload '""' => sub { my $self = shift @_; my $class = ref $self; $class =~ s/\AB:://xms; my $name = $self->name; "$class($name)"; }; package # hide from PAUSE B::SVOP; use overload '""' => sub { my $self = shift @_; my $class = ref $self; $class =~ s/\AB:://xms; my $name = $self->name; "$class($name," . $self->sv . "," . $self->gv . ")"; }; package # hide from PAUSE B::SPECIAL; sub DESTROY { } our $AUTOLOAD; sub AUTOLOAD { my $cx = 0; print "AUTOLOAD $AUTOLOAD\n"; package # hide from PAUSE DB; while ( my @stuff = caller $cx ) { print "$cx: [@DB::args] [@stuff]\n"; if ( ref $DB::args[0] ) { if ( $DB::args[0]->can('padix') ) { print " PADIX: " . $DB::args[0]->padix . "\n"; } if ( $DB::args[0]->can('targ') ) { print " TARG: " . $DB::args[0]->targ . "\n"; for ( B::Lint::cv()->PADLIST->ARRAY ) { print +( $_->ARRAY )[ $DB::args[0]->targ ] . "\n"; } } } ++$cx; } } 1;