El módulo B::LintSubs provee control sobre las llamadas a subrutinas no definidas:
pp2@nereida:/tmp$ perl -c -e 'use strict; foobar()' -e syntax OK pp2@nereida:/tmp$ perl -MO=LintSubs -c -e 'use strict; foobar()' Undefined subroutine foobar called at -e line 1
Veamos usando B::Concise el árbol generado para el programa del ejemplo:
pp2@nereida:~/src/perl$ perl -MO=Concise -e 'use strict; foobar()' 6 <@> leave[1 ref] vKP/REFC ->(end) 1 <0> enter ->2 2 <;> nextstate(main 2 -e:1) v/2 ->3 5 <1> entersub[t2] vKS/TARG,3 ->6 - <1> ex-list K ->5 3 <0> pushmark s ->4 - <1> ex-rv2cv sK/3 ->- 4 <#> gv[*foobar] s/EARLYCV ->5 -e syntax OKObserve la diferencia cuando la función
foo
existe:
pp2@nereida:~/src/perl$ perl -MO=Concise -e 'use strict; sub foobar {}; foobar()' 6 <@> leave[1 ref] vKP/REFC ->(end) 1 <0> enter ->2 2 <;> nextstate(main 3 -e:1) v/2 ->3 5 <1> entersub[t2] vKS/TARG,3 ->6 - <1> ex-list K ->5 3 <0> pushmark s ->4 - <1> ex-rv2cv sK/3 ->- 4 <#> gv[*foobar] s ->5 -e syntax OK
Analicemos el código de B::LintSubs . Las siguientes variables tiene por ámbito el fichero:
13 my $file = "unknown"; # shadows current filename 14 my $line = 0; # shadows current line number 15 my $curstash = "main"; # shadows current stash 16 my $curcv; # shadows current CV for current stash 17 18 my %done_cv; # used to mark which subs have already been linted 19 20 my $exitcode = 0;
El módulo O
llamará a la función compile
:
90 sub compile { 91 my @options = @_; 92 93 return \&do_lint; 94 }
Sigue el código de la función do_lint
:
78 sub do_lint { 79 my %search_pack; 80 81 $curcv = main_cv; 82 walkoptree_slow(main_root, "lint") if ${main_root()}; 83 84 no strict qw( refs ); 85 walksymtable(\%{"main::"}, "lintcv", sub { 1 } ); 86 87 exit( $exitcode ) if $exitcode; 88 }
La función main_cv devuelve el (falso) CV correspondiente al programa principal Perl.
La función main_root
retorna el objeto B::OP
raíz del árbol de operaciones
del programa principal.
La llamada walksymtable(SYMREF, METHOD, RECURSE)
recorre la tabla de símbolos comenzando en SYMREF
. el método METHOD
es llamado sobre cada símbolo visitado.
Cuando el recorrido alcanza un símbolo de paquete Foo::
llama
a la función RECURSE
y visita el paquete si la subrutina
devuelve verdadero.
67 sub B::GV::lintcv { 68 my $gv = shift; 69 my $cv = $gv->CV; 70 return if !$$cv || $done_cv{$$cv}++; 71 if( $cv->FILE eq $0 ) { 72 my $root = $cv->ROOT; 73 $curcv = $cv; 74 walkoptree_slow($root, "lint") if $$root; 75 } 76 }
pp2@nereida:/tmp$ sed -n '64,157p' `perldoc -l B::LintSubs` | cat -n 1 sub warning { 2 my $format = (@_ < 2) ? "%s" : shift; 3 warn sprintf("$format at %s line %d\n", @_, $file, $line); 4 } 5 6 sub lint_gv 7 { 8 my $gv = shift; 9 10 my $package = $gv->STASH->NAME; 11 my $subname = $package . "::" . $gv->NAME; 12 13 no strict 'refs'; 14 15 return if defined( &$subname ); 16 17 # AUTOLOADed functions will have failed here, but can() will get them 18 my $coderef = UNIVERSAL::can( $package, $gv->NAME ); 19 return if defined( $coderef ); 20 21 # If we're still failing here, it maybe means a fully-qualified function 22 # is being called at runtime in another package, that is 'require'd rather 23 # than 'use'd, so we haven't loaded it yet. We can't check this. 24 25 if( $curstash ne $package ) { 26 # Throw a warning and hope the programmer knows what they are doing 27 warning('Unable to check call to %s in foreign package', $subname); 28 return; 29 } 30 31 $subname =~ s/^main:://; 32 warning('Undefined subroutine %s called', $subname); 33 $exitcode = 1; 34 }
Por defecto la función lint
no hace nada:
36 sub B::OP::lint { }
Entre los métodos de un objeto B::COP
se cuentan
stash , file y line .
38 sub B::COP::lint { 39 my $op = shift; 40 if ($op->name eq "nextstate") { 41 $file = $op->file; 42 $line = $op->line; 43 $curstash = $op->stash->NAME; 44 } 45 }
47 sub B::SVOP::lint { 48 my $op = shift; 49 if ($op->name eq "gv" 50 && $op->next->name eq "entersub") 51 { 52 lint_gv( $op->gv ); 53 } 54 } 55 56 sub B::PADOP::lint { 57 my $op = shift; 58 if ($op->name eq "gv" 59 && $op->next->name eq "entersub") 60 { 61 my $idx = $op->padix; 62 my $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx]; 63 lint_gv( $gv ); 64 } 65 }