Creando un Envoltorio para una Subrutina

Supongamos que queremos crear una función wrap que establece un envoltorio (en la jerga un wrapper) a la llamada a una subrutina que se pasa como parámetro.

wrap 'mi_rutina', sub { print "Ejecutando mi_rutina con args <@_>\n" }

Por ejemplo, al hacer el siguiente wrap:

 1  #!/usr/local/bin/perl -w
 2  use strict;
 3  use Scalar::Util qw(looks_like_number);
 4  use List::MoreUtils qw(all);
 5
 6  sub wrap {
 7    my ($subname, $wrapper) = @_;
 8    die "Error in 'wrap': Provide a sub name\n" unless $subname =~ /[a-zA-Z_]\w+/;
 9    die "Error in 'wrap': No wrapper provided\n" unless ref($wrapper) eq 'CODE';
10
..    .....................................................................
18  }
19
20  sub square {
21    return map { $_ * $_ } @_;
22  }
23
24  wrap('square',
25       sub {
26         my $subname = shift;
27
28           die "Error en $subname: se esperaban números\n"
29         unless all { looks_like_number($_) } @_;
30
31         return @_;
32       }
33  );
34
35
36  my @a = square(5, 2);
37  print "square(5, 2) = (@a)\n";
38  @a = square(3, 'Juan', 9);
39  print "square(3, 'Juan', 9) = (@a)\n";

Obtenemos como resultado la ejecución:

lhp@nereida:~/Lperl/src$ wrap.pl
square(5, 2) = (25 4)
Error en main::square: se esperaban números

La subrutina wrap en el código que sigue comienza comprobando los parámetros. A continuación se construye el nombre completo de la función. La función caller devuelve el nombre del paquete desde el que se llamó a la función actual (véase la sección 1.15.10).

lhp@nereida:~/Lperl/src$ cat -n wrap.pl
 6  sub wrap {
 7    my ($subname, $wrapper) = @_;
 8    die "Error in 'wrap': Provide a sub name\n" unless $subname =~ /^((::)?\w+)+$/;
 9    die "Error in 'wrap': No wrapper provided\n" unless ref($wrapper) eq 'CODE';
10
11    my $fullspec = ($subname =~ /::/)? $subname : caller()."::$subname";
12
13    no strict 'refs';
14    my $subptr = *$fullspec{CODE};
15
16    no warnings 'redefine';
17    *{$fullspec} = sub { my @r = $wrapper->($fullspec, @_); return $subptr->(@r); };
18  }

En la línea 14 se hace un referenciado simbólico a un typeglob: *$fullspec. El typeglob resultante es indexado como hash en la entrada CODE (repase la sección 4.15.8). Esto nos deja en $subptr una referencia a la subrutina que se desea envolver.

En la línea 17 procedemos a sustituir la subrutina original por nuestra subrutina envoltorio. El compilador perl producirá un warning indicando que la subrutina ya existe. Esa es la razón para el no warnings 'redefine' de la línea 16. Para hacer la sustitución basta con usar un typeglob selectivo.