Re^2: Another Story (Detect undefined subroutines)

[diotalevi]

Here's a sketch of what this should look like. It might even work, as-is.

your_script.pl

use Strict::Subs;
foo(); # The subroutine main::foo might be called but it doesn't exist
+ yet.

Strict::Subs.pm

package Strict::Subs;
use strict;
use warnings;
use Exporter;
use B::Utils qw( all_roots anon_subs );
use vars qw( %Violations @ISA @EXPORT $VERSION );

BEGIN
{
    $VERSION = '0.01';
    @ISA = 'Exporter';
    @EXPORT = 'strict_subs';

    1;
}

sub import
{
    eval q[
CHECK
{
    # Provide a named way to trigger this
    apply_strict_subs();

    1;
}
];
}

sub strict_subs ()
{
    'strict_subs()';
}

sub apply_strict_subs
{
    local %Violations;

    # All named subroutines.
    {
        my %named_subs = all_roots();
        _strict_sub( $_ ) for values %named_subs;
    }

    # All anonymous subroutines
    _strict_sub( $_->{'root'} ) for anon_subs();

    1;
}

sub _strict_sub
{
    my $root = shift;
    
    walkoptree_filtered( $root,
                         \ &_find_strict_sub_invocation,
                         \ &_apply_strict_subs );

    1;
}

sub _find_strict_sub_invocation
{
    my $op = shift;

    opgrep( { name => 'gv' }, $op )
    and
    do { my $gv = $op->sv;
         ( $gv->NAME eq 'strict_subs'
           and
           $gv->STASH->NAME eq 'Strict' ) }
}

sub _apply_strict_subs
{
    my $op = shift;

    walkoptree_filtered( $_,
                         \ &_find_subroutine_calls,
                         \ &_validate_subroutine_existance )
        for $op->younger_siblings();

    1;
}

sub _find_subrountine_calls
{
    opgrep( { name => 'gv' 
              next => { name => 'entersub ' } } );
}

sub _validate_subroutine_existance
{
    my $op_gv = shift;
    my $gv = $op_gv->sv;
    my $name = $gv->STASH->NAME . '::' . $gv->NAME;

    no strict 'refs';
    *{$name}{'CODE'}
        or warn "The subroutine $name might be called but it doesn't e
+xist yet.\n"
}

package B::Utils;

sub younger_siblings
{
    my $op = shift;

    my @siblings;
    for ( my $sibling = $op->sibling;
          $sibling->oldname ne 'null';
          $op = $sibling )
    {
        push @siblings, $sibling;
    }
    @siblings;
}

[ihb]

Check out B::Lint. Here's an excerpt from the manual:

undefined-subs
        This option warns whenever an undefined subroutine is invoked.
        This option will only catch explicitly invoked subroutines suc
+h
        as "foo()" and not indirect invocations such as "&$subref()" o
+r
        "$obj->meth()". Note that some programs or modules delay
        definition of subs until runtime by means of the AUTOLOAD
        mechanism.

ihb

Read argumentation in its context!