summaryrefslogtreecommitdiff
path: root/chromium/third_party/cygwin/lib/perl5/5.10/i686-cygwin/B/Lint.pm
diff options
context:
space:
mode:
Diffstat (limited to 'chromium/third_party/cygwin/lib/perl5/5.10/i686-cygwin/B/Lint.pm')
-rw-r--r--chromium/third_party/cygwin/lib/perl5/5.10/i686-cygwin/B/Lint.pm792
1 files changed, 792 insertions, 0 deletions
diff --git a/chromium/third_party/cygwin/lib/perl5/5.10/i686-cygwin/B/Lint.pm b/chromium/third_party/cygwin/lib/perl5/5.10/i686-cygwin/B/Lint.pm
new file mode 100644
index 00000000000..76bc9fd0236
--- /dev/null
+++ b/chromium/third_party/cygwin/lib/perl5/5.10/i686-cygwin/B/Lint.pm
@@ -0,0 +1,792 @@
+package B::Lint;
+
+our $VERSION = '1.11'; ## 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 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 $_';
+ }
+
+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[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;
+ 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;
View Lorry Controller Status