-3

私の perl スクリプトには多くのサブルーチンがあります。サブルーチンごとにログを作成したいです。つまり、サブルーチンが正常に機能したかどうか、または失敗した場合はどこで失敗したかをログに記録します。ロジック フラグを維持する必要があるため、フラグ値に基づいてサブルーチン ログが作成されます。私はperlを初めて使用するので、誰かが同じ例を教えてくれますか?

4

2 に答える 2

0

あなたがやろうとしていることは、ロギングステートメントを手動で挿入することによって達成できます:

use constant LOG => 1;

sub foo {
  debug 'BEFORE', 'main::foo', @_ if LOG; # gets optimized away if LOG is false
  do stuff;
  debug 'AFTER', 'main::foo', if LOG;      # the same
  return $things;
}

debug（ロギングを行う関数であると仮定）

ただし、特定のケースでは自動化できます。特に、名前付きサブルーチンごとにロギング ラッパーを追加できます。これは、シンボル テーブルであるパッケージ stashを介したメタプログラミングとして行います。

stash は、 のような名前の大きなハッシュ%main::です。末尾の二重コロンに注意してください。これは、キーの固定セットを持つハッシュであるglobを保持します。彼らは*印章を持っています。CODEグロブのエントリには、コード参照が保持されます。

次のようなコードエントリを保持するスタッシュのすべてのグロブを選択できます

my $stash = \%main::;
my @interesting_globs = grep *$_{CODE}, values %$stash;

参照をグロブに割り当てることができます。これにより、グロブに正しいスロットが設定されます。例えば、

sub foo { say 1 }

とほぼ同じものです

BEGIN {
  *foo = sub { say 1 };
}

これで、ロギングを行うラッパーで元のサブをラップできます。

for my $glob (@interesting_globs) {
  my $code = *$glob{CODE}; # store the coderef in a lexical variable
  no warnings 'redefine';
  *$glob = sub {
     debug 'BEFORE', $glob, @_ if LOG;
     my @return_value = wantarray ? &$code : scalar &$code;
     debug 'AFTER', $glob, @return_value if LOG;
     return wantarray ? @return_value : $return_value[0];
  }
}

これwantarrayにより、内側のサブルーチンが正しいコンテキスト (リスト コンテキスト/スカラー コンテキスト) で呼び出されるようになります。ただし、無効なコンテキストはチェックしません。(かっこがないことに注意してください) は、 or&$codeの派手な言い方です。$code->(@_)&$code(@_)

すべてのサブルーチンがコンパイルされた後、サブルーチンが装飾されることが重要です。したがって、INITメインのコンパイル段階の後、通常の実行が開始される前に実行されるブロック内で実行する必要があります。

このソリューションにはいくつかの欠点があります。

  1. 名前付きサブスクでのみ機能しますが、匿名サブスクでは機能しません。
  2. また、デフォルトでインポートされたサブを装飾します。
  3. それ以上のフィルターがなければ、すべてのサブを飾ります。
  4. void コンテキストを元のコードに伝播しません。

より良い解決策はsubroutine attributesを使用することですが、セットアップが少し難しいです。属性は、コンパイル時に実行され、メタデータを伝達できるハンドラーです。たとえばsub foo :log_this { ... }では、log_thisハンドラが呼び出されます。

完全な例:

$ perl -E'
  sub foo {say "@_"};
  sub bar { foo(0, @_, "inf") }
  INIT{
    for my $glob (grep *$_{CODE}, values %main::){
      my $orig = *$glob{CODE};
      *$glob = sub {
        say "BEFORE $glob: @_";
        my @ret = $orig->(@_); # this demo misses context handling
        say "AFTER $glob: @ret";
        @ret;
      };
    }
  }
  bar(1,2,3)'
BEFORE *main::bar: 1 2 3
BEFORE *main::foo: 0 1 2 3 inf
0 1 2 3 inf
AFTER *main::foo: 1
AFTER *main::bar: 1
于 2013-06-17T15:39:40.620 に答える