diff options
author | Karl Berry <karl@freefriends.org> | 2015-04-26 22:16:26 +0000 |
---|---|---|
committer | Karl Berry <karl@freefriends.org> | 2015-04-26 22:16:26 +0000 |
commit | 342e672574c4e67d510e46ab6acd0e21a7d0cf54 (patch) | |
tree | 79e04202d08c0404bbd780bd26c1e34710e539b6 /Master/tlpkg/tlperl/lib/B/Lint.pm | |
parent | be2706af7c57a0ef0f4d4e9f684ca4ef74922a82 (diff) |
(tl)perl 5.20.2 for windows, from siep
git-svn-id: svn://tug.org/texlive/trunk@37064 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/B/Lint.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Lint.pm | 793 |
1 files changed, 0 insertions, 793 deletions
diff --git a/Master/tlpkg/tlperl/lib/B/Lint.pm b/Master/tlpkg/tlperl/lib/B/Lint.pm deleted file mode 100644 index fd8d75e53ac..00000000000 --- a/Master/tlpkg/tlperl/lib/B/Lint.pm +++ /dev/null @@ -1,793 +0,0 @@ -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<perl>. It is named after the program F<lint> 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<all> and B<none> options) is a -word representing one possible lint check (turning on that check) or -is B<no-foo> (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<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 -context. For example, both of the lines - - $foo = length(@bar); - $foo = @bar; - -will elicit a warning. Using an explicit B<scalar()> silences the -warning. For example, - - $foo = scalar(@bar); - -=item B<implicit-read> and B<implicit-write> - -These options produce a warning whenever an operation implicitly -reads or (respectively) writes to one of Perl's special variables. -For example, B<implicit-read> will warn about these: - - /foo/; - -and B<implicit-write> will warn about these: - - s/foo/bar/; - -Both B<implicit-read> and B<implicit-write> warn about this: - - for (@a) { ... } - -=item B<bare-subs> - -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<dollar-underscore> - -This option warns whenever C<$_> is used either explicitly anywhere or -as the implicit argument of a B<print> statement. - -=item B<private-names> - -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<undefined-subs> - -This option warns whenever an undefined subroutine is invoked. -This option will only catch explicitly invoked subroutines such -as C<foo()> and not indirect invocations such as C<&$subref()> -or C<$obj-E<gt>meth()>. Note that some programs or modules delay -definition of subs until runtime by means of the AUTOLOAD -mechanism. - -=item B<regexp-variables> - -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<perlre> for -details. - -=item B<all> - -Turn all warnings on. - -=item B<none> - -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<Module::Pluggable> -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<Module::Pluggable> then your class name is -added to the list of plugins. - -You must create a C<match( \%checks )> 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(<FH>) 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<grep EXPR, ...> or C<grep - # { EXPR } ...>, 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<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 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<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; - 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<<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; - } - } - -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; |