Как мне переопределить встроенные функции Perl?

Question

Я хочу сделать две вещи:

В рабочем коде я хочу переопределить команду open, чтобы я мог добавить автоматическое ведение журнала файлов. Я работаю над приложениями / потоками обработки данных, и для этого важно, чтобы пользователь точно знал, какие файлы обрабатываются. Если они используют старую версию файла, один из способов выяснить это - прочитать список обрабатываемых файлов.

Я мог бы просто создать новую подпрограмму, которая ведет эту запись и возвращает указатель файла, и использовать его вместо open в моем коде.

Было бы очень хорошо, если бы я мог просто переопределить open и использовать уже существующий код, извлекающий выгоду из этого поведения. Могу ли я сделать это?

В отладочном коде я хотел бы переопределить команду printf, чтобы вставить комментарии вместе с письменным выводом, указывающим, какой код сгенерировал эту строку. Опять же, у меня есть саб, который по желанию сделает это, но преобразование моего существующего кода утомительно.

Answer 1

Если подпрограмма CORE имеет прототип *, ее можно заменить. Замена функции в текущем пространстве имен достаточно проста.

#!/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;

Если вы хотите переопределить функцию и для всех модулей, вы можете прочитать документы .

* Вот код для проверки каждой функции в Perl 5.10 (она будет работать и в более ранних версиях). Обратите внимание, что некоторые функции могут быть переопределены, что эта программа скажет, что вы не можете, но переопределенная функция не будет вести себя так же, как исходная функция.

из прототипа perldoc -f

Если встроенное не переопределено (например, qw //) или если его аргументы не может быть адекватно выражено прототип (такой как система), prototype () возвращает undef, потому что встроенный на самом деле не ведет себя как 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

Answer 2

Для открытия: Это сработало для меня.

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';

Для Printf: Вы проверяли этот вопрос? -> Как я могу подключиться к печати Perl?