¿Cómo redefino las funciones integradas de Perl?

Question

Quiero hacer dos cosas:

En el código de producción, quiero redefinir el comando de abrir para permitirme agregar el registro automático de archivos. Trabajo en aplicaciones/flujos de procesamiento de datos y, como parte de eso, es importante que el usuario sepa exactamente qué archivos se están procesando. Si están usando una versión anterior de un archivo, una forma de que lo descubran es leyendo la lista de archivos que se procesan.

Podría simplemente crear un nuevo sub que hace este registro y devuelve un puntero de archivo y usarlo en lugar de abrir en mi código.

Sería muy bueno si pudiera simplemente redefinir abierto y tener un código preexistente que se beneficie de este comportamiento. ¿Puedo hacer esto?

En el código de depuración, me gustaría redefinir el comando printf para insertar comentarios junto con el resultado escrito que indica qué código generó esa línea. De nuevo, tengo un sub que opcionalmente hará esto, pero la conversión de mi código existente es tediosa.

Answer 1

Para abrir: Esto funcionó para mí.

use 5.010; 
use strict; 
use warnings; 
use subs 'open'; 
use Symbol qw<geniosym>; 

sub open (*$;@) { 
    say "Opening $_[-1]"; 
    my ($symb_arg) = @_; 
    my $symb; 
    if (defined $symb_arg) { 
     no strict; 
     my $caller = caller(); 
     $symb = \*{$symb_arg}; 
    } 
    else { 
     $_[0] = geniosym; 
    } 
    given (scalar @_) { 
     when (2) { return CORE::open($symb // $_[0], $_[1]); } 
     when (3) { return CORE::open($symb // $_[0], $_[1], $_[2]); } 
    } 
    return $symb; 
} 

open PERL4_FH, '<', 'D:\temp\TMP24FB.sql'; 
open my $lex_fh, '<', 'D:\temp\TMP24FB.sql'; 

Para Printf: ¿verificó a cabo esta pregunta? ->How can I hook into Perl’s print?

Answer 2

Si una subrutina CORE tiene un prototipo * se puede reemplazar. Reemplazar una función en el espacio de nombres actual es bastante simple.

#!/usr/bin/perl 

use strict; 
use warnings; 

use subs 'chdir'; 

sub chdir(;$) { 
    my $dir = shift; 
    $dir = $ENV{HOME} unless defined $dir; 
    print "changing dir to $dir\n"; 
    CORE::chdir $dir; 
} 

chdir("/tmp"); 
chdir; 

Si desea anular la función para todos los módulos, así se puede leer el docs.

* Aquí está el código para probar cada función en Perl 5.10 (también funcionará en versiones anteriores). Tenga en cuenta que se pueden anular algunas funciones que este programa dirá que no puede ser, pero la función anulada no se comportará de la misma manera que la función original.

desde el prototipo perldoc -f

Si la orden interna no es reemplazable (como qw //) o si sus argumentos no se pueden expresar adecuadamente por un prototipo (como el sistema), prototipo() devuelve undef, debido a que el incorporado en realidad no se comporta como una función Perl

#!/usr/bin/perl 

use strict; 
use warnings; 

for my $func (map { split } <DATA>) { 
    my $proto; 
    #skip functions not in this version of Perl 
    next unless eval { $proto = prototype "CORE::$func"; 1 }; 
    if ($proto) { 
     print "$func has a prototype of $proto\n"; 
    } else { 
     print "$func cannot be overridden\n"; 
    } 
} 

__DATA__ 
abs   accept   alarm   atan2   bind   
binmode  bless   break   caller   chdir 
chmod  chomp   chop   chown   chr 
chroot  close   closedir  connect   continue 
cos   crypt   dbmclose  defined   delete 
die   do    dump   each    endgrent 
endhostent endnetent  endprotoent endpwent   endservent 
eof   eval   exec   exists   exit 
exp   fcntl   fileno   flock   fork 
format  formline  getc   getgrent   getgrgid 
getgrnam  gethostbyaddr gethostbyname gethostent  getlogin 
getnetbyaddr getnetbyhost getnetent  getpeername  getpgrp 
getppid  getpriority getprotobyname getprotobynumber getprotoent 
getpwent  getpwnam  getpwuid  getservbyname getservbyport 
getservent getsockname getsockopt  glob    gmtime 
goto   grep   hex   import   index 
int   ioctl   join   keys    kill 
last   lc    lcfirst  length   link 
listen  local   localtime  lock    log 
lstat  m    map   mkdir   msgctl 
msgget  msgrcv   msgsnd   my    next 
no   oct   open   opendir   ord 
our   pack   package  pipe    pop 
pos   print   printf   prototype  push 
q   qq    qr    quotemeta  qw 
qx   rand   read   readdir   readline 
readlink  readpipe  recv   redo    ref 
rename  require  reset   return   reverse 
rewinddir rindex   rmdir   s    say 
scalar  seek   seekdir  select   semctl 
semget  semop   send   setgrent   sethostent 
setnetent setpgrp  setpriority setprotoent  setpwent 
setservent setsockopt  shift   shmctl   shmget 
shmread  shmwrite  shutdown  sin    sleep 
socket  socketpair  sort   splice   split 
sprintf  sqrt   srand   stat    state 
study  sub   substr   symlink   syscall 
sysopen  sysread  sysseek  system   syswrite 
tell   telldir  tie   tied    time 
times  tr    truncate  uc    ucfirst 
umask  undef   unlink   unpack   unshift 
untie  use   utime   values   vec 
wait   waitpid  wantarray  warn    write 
y   -r    -w    -x    -o 
-R   -W    -X    -O    -e 
-z   -s    -f    -d    -l 
-p   -S    -b    -c    -t 
-u   -g    -k    -T    -B 
-M   -A    -C