lint.pm

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

        # 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::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;