evalと$SIG{__DIE__}とcaller - local $PERL_MEMO;

September 19, 2008

■ [perl]evalと$SIG{DIE}とcaller 01:37

例えばAPIなんかを作っていて、ブラウザに簡単なエラーメッセージを表示させたい時に以下のようなことをすることがあるかもしれない。

BEGIN {
  $SIG{__DIE__} = sub {
    print "Status: 500 Internal Server Error\n"
          , "Content-Type: text/plain; charset=UTF-8\n"
          , "\n";

    local $_;
    ( $_ = shift ) =~ s/ at (?!.* at ).*$/\n/;
    print; die;
  }
}

open FILE, 'file' or die "Cannot open 'file'."; # とか
die 'No such user.' unless check_user_id($q->{user_id}); # とか

上記は期待通り、

Cannot open 'file'.

と表示されると思います。

ところが、このままだとevalで例外処理をしようとした時に困ったことになってしまう。

BEGIN {
  $SIG{__DIE__} = sub {
    print "Status: 500 Internal Server Error\n"
          , "Content-Type: text/plain; charset=UTF-8\n"
          , "\n";

    local $_;
    ( $_ = shift ) =~ s/ at (?!.* at ).*$/\n/;
    print; die;
  }
}

eval {
  require "additional.pl"; # additional.pl はなくてもかまわない
};
if ($@) {
  # requireに失敗したときの動作
}

print "Status: 200 OK\n"
      , "Content-Type: text/plain; charset=UTF-8\n"
      , "\n";
print "looks good!\n";

上記は 200 OK であって欲しいんだけど、

Can't locate additional.pl in @INC

Status: 200 OK
Content-Type: text/plain; charset=UTF=8

looks good!

statusは 500 Internal Server Error. ちっとも looks good じゃない。。。

以上、自分の話でした

evalのときは$SIG{__DIE__}実行して欲しくない！ということがあったので、その回避方法をメモっておきます。

callerを使う

callerは実行中のサブルーチンを呼んだ親の情報を返します。呼び出し元情報のほうが正しいかもしれない。

callerは引数に何も渡さないと、呼び出し元のpackage名、ライブラリやモジュールなどのfile名、呼び出した行番号を返します。

my ($package, $filename, $line) = caller;

引数を渡すと詳細な情報を返します。0が直前の呼び出し元。1,2,3...と引数を大きくしていくと親の親の情報を返す。親がいなくなったらundef. それぞれの変数には変数名な感じの情報が入ります。

my ($package, $filename, $line, $subroutine, $hasargs, 
      $wantarray, $evaltext, $is_require, $hints, $bitmask) = caller(0);

詳しいことはperldoc -f callerで。

で。

今回注目したいのが $subroutine なんですが、perldoc によると eval から呼び出されたときには $subroutine に (eval) が入るみたい。eval EXPR と eval BLOCK で微妙に状況が異なるらしいけど、とりあえず $subroutine = '(eval)' みたいなので気にしない。

まとめるのがめんどくさい

evalの中で死んだときはcallerの呼び出し元のどこかには必ずevalが出てくるので、以下のような感じにしてみました。

BEGIN {
  $SIG{__DIE__} = sub {
    my $i = 0;
    while (my $sub = (caller($i++))[3]) {
      return if $sub eq '(eval)';
    }

    print "Status: 500 Internal Server Error\n"
          , "Content-Type: text/plain; charset=UTF-8\n"
          , "\n";

    local $_;
    ( $_ = shift ) =~ s/ at (?!.* at ).*$/\n/;
    print; die;
  }
}

eval {
  require "additional.pl"; # additional.pl はなくてもかまわない
};
if ($@) {
  # requireに失敗したときの動作
}

print "Status: 200 OK\n"
      , "Content-Type: text/plain; charset=UTF-8\n"
      , "\n";
print "looks good!\n";

looks good!

追記(2008/10/06)

perlfunc見てたら「evalから$SIG{__DIE__}呼び出された時に何もしたくないときは die @_ if $^S してね！」って書いてあった…

perlvarによれば、evalから実行されたときに $^S は true(1) になるそうな。なので caller のチェックなんて面倒くさいことしなくても return if $^S でおｋ。詳しくは perldoc perlvar.

BEGIN {
  $SIG{__DIE__} = sub {
    return if $^S;

    print "Status: 500 Internal Server Error\n"
          , "Content-Type: text/plain; charset=UTF-8\n"
          , "\n";

    local $_;
    ( $_ = shift ) =~ s/ at (?!.* at ).*$/\n/;
    print; die;
  }
}

eval {
  require "additional.pl"; # additional.pl はなくてもかまわない
};
if ($@) {
  # requireに失敗したときの動作
}

print "Status: 200 OK\n"
      , "Content-Type: text/plain; charset=UTF-8\n"
      , "\n";
print "＞＜\n";

＞＜

コメントを書く

local $PERL_MEMO;