12

我想做两件事：

在生产代码中，我想重新定义 open 命令以使我能够添加自动文件日志记录。我从事数据处理应用程序/流程的工作，作为其中的一部分，用户必须确切地知道正在处理哪些文件。如果他们使用的是旧版本的文件，他们找出的一种方法是通读正在处理的文件列表。

我可以创建一个新的sub来执行此日志记录并返回一个文件指针，并在我的代码中使用它来代替 open。

如果我可以重新定义 open 并让预先存在的代码从这种行为中受益，那就太好了。我可以这样做吗？

在调试代码中，我想重新定义printf命令以插入注释以及指示哪个代码生成该行的书面输出。同样，我有一个可以选择执行此操作的子程序，但是转换我现有的代码很乏味。

4

2 回答 2

13

如果一个 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//），或者如果它的参数不能被原型充分表达（例如 system），则原型（）返回 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
于 2009-03-16T20:14:28.890 回答
9

对于开放：这对我有用。

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 的打印？

于 2009-03-16T17:04:05.900 回答