lint.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

package B::Lint;

our $VERSION = '1.09';    ## 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, [e-mail].

=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