Suprimiendo Subrutinas con Typeglobs y Referenciado Simbólico

En (raras) ocasiones queremos eliminar completamente una subrutina. Las ocasiones en las que he visto en la necesidad de hacerlo son aquellas en las que la existencia de una subrutina afecta de forma no deseada al comportamiento de otra (recuerde que en Perl una subrutina puede saber dinámicamente si cierta subrutina existe mediante el uso de can).

La distribución Parse::Eyapp provee el módulo Parse::Eyapp::Base el cual provee las funciones delete_method e insert_method para suprimir y bautizar subrutinas. Vea un ejemplo de uso:

pl@nereida:~/LEyapp/examples$ cat -n localwithinsert.pl
 1  #!/usr/local/bin/perl -w
 2  use strict;
 3
 4  package Tutu;
 5  use Parse::Eyapp::Base qw(:all);
 6
 7  my $tutu = sub {
 8    "inside tutu\n"
 9  };
10
11  sub plim {
12    insert_method(_tutu => $tutu);
13
14    print _tutu();
15
16    delete_method('_tutu');
17  }
18
19  package main;
20
21  Tutu::plim();
22  print(main->can('Tutu::_tutu')? (Tutu::_tutu()."\n") : "Can't do tutu\n");
23  Tutu::plim();

Cuando se ejecuta el código anterior produce la salida:

pl@nereida:~/LEyapp/examples$ localwithinsert.pl
inside tutu
Can't do tutu
inside tutu

La subrutina delete_method('subname', qw{class1 class2 class3}) elimina la subrutina subname en los paquetes Class1, Class2 y Class1:

pl@nereida:~/LEyapp/lib/Parse/Eyapp$ sed -ne '144,172p' Base.pm | cat -n
 1  sub delete_method {
 2    my $name = pop;
 3    $name = '' unless defined($name);
 4    croak "Error in delete_method: Illegal method name <$name>\n" unless $name =~/^\w+$/;
 5    my @classes = @_;
 6
 7    @classes = scalar(caller) unless @classes;
 8    no strict 'refs';
 9    for (@classes) {
10      croak "Error in delete_method: Illegal class name <$_>\n" unless /^[\w:]+$/;
11      unless ($_->can($name)) {
12        print STDERR "Warning in delete_method: No sub <$name> to delete in package <$_>\n";
13        next;
14      }
15      my $fullname = $_."::".$name;
16
17      # Temporarily save the other entries
18      my @refs = map { *{$fullname}{$_} } qw{HASH SCALAR ARRAY GLOB};
19
20      # Delete typeglob
21      *{$fullname} = do { local *{$fullname} };
22
23      # Restore HASH SCALAR ARRAY GLOB entries
24      for (@refs) {
25        next unless defined($_);
26        *{$fullname} = $_;
27      }
28    }
29  }

Se salvan las referencias a los viejos valores de los diversos tipos con un typeglob selectivo:

my @refs = map { *{$fullname}{$_} } qw{HASH SCALAR ARRAY GLOB}

Después se elimina la entrada del typeglob usando local:

*{$fullname} = do { local *{$fullname} }

La expresión local *{$fullname} elimina temporalmente el typeglob (lo deja undef) y retorna el typeglob. Como queremos hacer permanente la eliminación del typeglob. Véase el siguiente ejemplo ilustrativo con el depurador:

lhp@nereida:~/Lperl/src/perl_networking/ch2$ perl -wde 0
main::(-e:1):   0
  DB<1> @x = 1..5; $x = 'hola'
  DB<2> $c = 'x'
  DB<3> x  local *{$c}
0  *main::x
  DB<4> p $x
hola
  DB<6> x *{$c} = { local *{$c} }
Odd number of elements in anonymous hash at (eval 10)[/usr/share/perl/5.8/perl5db.pl:628] line 2.
  DB<7> x *{$c} = do { local *{$c} }
0  *main::x
  DB<8> print $x
Use of uninitialized value in print at (eval 12)[/usr/share/perl/5.8/perl5db.pl:628] line 2.

y por último se restauran los viejos valores excepto el de código.