最近Perlさんに飯を食わせてもらうようになりました

ところでいろんな環境にそれなりにポーティングされていて手っ取り早く使えるスクリプト言語ってやっぱPerlなんですね．最近になってそれが身に染みて感じるようになりました．そんなPerlですがFIle::chdirのpodを読んでて挙動が気になったのでソース読んだらtieっていう関数を知りました．遊ぶ分には楽しめそうだと思ってロガーを書いてみました．

package Hoge;
use strict;
use warnings;
use utf8;
use POSIX 'strftime';
use Time::HiRes 'gettimeofday';

if (exists($ARGV[0])) {
    tie *STDOUT, __PACKAGE__, 'a.log';
}

sub TIEHANDLE {
    my $class = shift;
    my $fn = shift;
    open(my $f, '>>', $fn);
    select((select($f), $| = 1)[0]);
    bless \$f, $class;
}
sub PRINT {
    my $self = shift;
    my $fh = ${$self}; # なんでか一旦置き換えしないと怒られる
    my $tag = (scalar @_ > 1)? shift:'DBG';
    my $msec = sprintf("%06d", (gettimeofday())[1]);
    my ($package, $filename, $line, $subroutine, $hasargs,
     $wantarray, $evaltext, $is_require, $hints, $bitmask) = caller(1);
    my $output = "@{[strftime('%Y-%m-%d.%H:%M:%S', localtime)]}.$msec [$tag] $subroutine:$line @{[join(' ', @_)]}";
    print $fh $output;
}

sub DESTORY {
    my $self = shift;
    my $fh = ${$self};
    close($fh);
}

package main;
sub {
    print 1,"hoge\n";
    print "fuga\n";
}->();
eval {
    print 'hige', "piyo\n";
    print "funya\n";
}; if ($@){}

適当な名前で保存して実行するとtieの引数で渡したファイルにこんなんが書かれます．(PRINTでグチャグチャ文字列を持ってるのが気にいらないですね．)

2010-09-05.13:50:10.022877 [1] main::__ANON__:42 hoge
2010-09-05.13:50:10.024172 [DBG] main::__ANON__:42 fuga
2010-09-05.13:50:10.024367 [hige] (eval):43 piyo
2010-09-05.13:50:10.024496 [DBG] (eval):43 funya