How do I redefine built-in Perl functions? - perl

Question

I want to do two things:
In production code, I want to redefine the open command to enable me to add automagic file logging. I work on data processing applications/flows and as part of that, it's important for the user to know exactly what files are being processed. If they are using an old version of a file, one way for them to find out is by reading through the list of files being processed.
I could just create a new sub that does this logging and returns a file pointer and use that in place of open in my code.
It would be really nice if I could just redefine open and have pre-existing code benefit from this behavior. Can I do this?
In debug code, I'd like to redefine the printf command to insert comments along with the written output indicating which code generated that line. Again, I have a sub that will optionally do this, but converting my existing code is tedious.

Answer 1

If a CORE subroutine has a prototype* it can be replaced. Replacing a function in the current namespace is simple enough.
#!/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;
If you want to override the function for all modules as well you can read the docs.
* Here is code to test every function in Perl 5.10 (it will work on earlier versions as well). Note, some functions can be overridden that this program will tell you can't be, but the overridden function will not behave in the same way as the original function.
from perldoc -f prototype
If the builtin is not overridable
(such as qw//) or if its arguments
cannot be adequately expressed by a
prototype (such as system),
prototype() returns undef, because the
builtin does not really behave like a
Perl function
#!/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

For open: This worked for me.
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';
For Printf: Did you check out this question? -> How can I hook into Perl’s print?