Un Ejemplo: B::LintSubs

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 OK

Observe 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.

B::GV

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  }