use strict;
use warnings;

=head2 call_user_func

 $ret = call_user_func($function,@param);
 $ret = call_user_func([$class,$method],@param);

example1

 sub plus { $_[0] + $_[1] }
 print call_user_func('plus',10,20); # 30

example2

 package Foo;
 sub plus { $_[1] + $_[2] }
 package main;
 print call_user_func(['Foo','plus'],10,20); # 30

=cut

sub call_user_func {
    my $proto = shift;
    if ( ref $proto eq 'ARRAY' ) {
        return $$proto[0]->${\$$proto[1]}(@_);
    }
    else {
        require Pod::Functions;
        if ( $Pod::Functions::Flavor{$proto} ) {
            return eval qq{$proto(\@_)};
        }
        else {
            no strict 'refs';
            return $proto->(@_);
        }
    }
}

=head2 call_user_func_array

 $ret = call_user_func_array($function,\@param);
 $ret = call_user_func_array([$class,$method],\@param);

example

 sub plus { $_[0] + $_[1] }
 print call_user_func_array('plus',[10,20]); # 30

=cut

sub call_user_func_array {
    return call_user_func(shift,@{+shift});
}

=head2 create_function

 $code = create_function($args_str,$code_str);

example

 $code = create_function('$c,$d=1','print $c+$d');
 $code->(10); # 11

=cut

sub create_function {
    my $args = shift;
    my $code = shift;
    my $default = 0;
    my @args = split /,/,$args;
    my $code_str = 'sub {';
    for my $arg (@args) {
        if ( $arg =~ /^\s*(\$[a-zA-Z][\w]*)\s*(?:=\s*(.+))?\s*$/ ) {
            my $val = $1;
            my $def = $2;
            if ( defined $def ) {
                $default = 1;
                $code_str .= qq{my $val = \@_ ? shift : $def;\n};
            }
            else {
                die 'parse error' if $default;
                $code_str .= qq{my $val = shift;\n};
            }
        }
    }
    $code_str .= $code . '}';
    my $sub = eval $code_str;
    die $@ if $@;
    return $sub;
}

=head2 forward_static_call

 $ret = forward_static_call($function,@param);
 $ret = forward_static_call([$class,$method],@param);

=cut

sub forward_static_call {
    call_user_func(@_);
}

=head2 forward_static_call_array

 $ret = forward_static_call_array($function,\@param);
 $ret = forward_static_call_array([$class,$method],\@param);

=cut

sub forward_static_call_array {
    call_user_func_array(@_);
}

=head2 func_get_arg

 $arg = func_get_arg($no)

example

 sub foo { print func_get_arg(1) }
 foo(100,200); # 200

=cut

sub func_get_arg {
    my $n = shift;
    package DB;
    @DB::args = ();
    () = caller(1);
    return defined $DB::args[$n] ? $DB::args[$n] : undef;
}

=head2 func_get_args

 @args = func_get_args()

example

 sub foo { print join ':', func_get_args() }
 foo(11,22,33); # 11:22:33

=cut

sub func_get_args {
    my $n = shift;
    package DB;
    @DB::args = ();
    () = caller(1);
    return @DB::args;
}

=head2 func_num_args

 $arg_count = func_num_args()

example

 sub foo { print func_num_args() }
 foo(11,22,33); # 3

=cut

sub func_num_args {
    my $n = shift;
    package DB;
    @DB::args = ();
    () = caller(1);
    return scalar @DB::args;
}

=head2 function_exists

 $bool = function_exists($func)

example

 sub foo {}
 print function_exists('foo');  # 1
 print function_exists('bar');  # 0
 print function_exists('rand'); # 1

=cut

sub function_exists {
    my $func = shift;
    return 1 if exists &$func;
    require Pod::Functions;
    return $Pod::Functions::Flavor{$func} ? 1 : 0;
}

=head2 get_defined_functions

 $funcs = get_defined_functions()

=cut

sub get_defined_functions {
    require Pod::Functions;
    return {
        internal => [ keys %Pod::Functions::Flavor ],
        user     => [ grep { exists &$_ } keys %:: ],
    };
}

=head2 register_shutdown_function

 register_shutdown_function($func,@param);
 register_shutdown_function([$class,$method],@param);

=cut

{
    my $REGISTER_SHUTDOWN_FUNCTION = [];
    sub register_shutdown_function {
        my $proto = shift;
        push @$REGISTER_SHUTDOWN_FUNCTION, [
            do {
                if ( ref $proto eq 'ARRAY' ) {
                    $$proto[0]->can($$proto[1]);
                }
                else {
                    require Pod::Functions;
                    if ( $Pod::Functions::Flavor{$proto} ) {
                        sub { eval qq{$proto(\@_)} };
                    }
                    else {
                        no strict 'refs';
                        \&$proto;
                    }
                }
            },
            [@_]
        ]
    }
    END {
        $_->[0]->(@{$_->[1]}) for @$REGISTER_SHUTDOWN_FUNCTION;
    }
}

思ったよりも難しかった。標準関数一覧を取る手段がなかったので標準モジュールを利用して標準関数の一覧を取得した。

あと文字列から標準関数を呼び出すスマートな手段が思いつかなかったのでeval便りに。

create_functionはかなりゴリ押し。myを勝手に付けたりデフォルト引数にも対応してたり細かい芸が光る（自分で言うな）

forward_static_callはぶっちゃけ Perl的にcall_user_funcと殆ど処理が変わらないのでそのまま利用。

func_get_arg系は結構クリティカルだなー。@DB::argsをリアルに使ったの初めてだよ。

register_shutdown_functionはちょっとねー。ENDブロックを利用してるわけなんだけど当然mod_perlとかではうまく動かない。あとシグナルとか使った方が良いのかもしれない。

ヒマがあったら他の関数とかも実装してみたいかも。

プログラ増田のあなぐら

Permalink | 記事への反応(1) | 18:39

2007-08-21

■X-REPROXY-CACHE-CLEAR もあわせて使いたい人向けショート BK

■X-Reproxy-Cache-Clear できる Perlbal プラグインCommentsAdd Star

■[Perl][CPAN][Perlbal] X-REPROXY-CACHE-FORを使いたい人向けショートBK

X-REPROXY-CACHE-FOR ヘッダが Perlbal に(というか Perlbal::Cache に)どのように解釈されるかというと、

Perlbal::Service.pm

1467 sub add_to_reproxy_url_cache {
1468 my Perlbal::Service $self;
1469 my ($reqhd, $reshd);
1470
1471 ($self, $reqhd, $reshd) = @_;
1472
(snip)
1484 my $hostname = $reqhd->header("Host") || '';
1485 my $requri = $reqhd->request_uri || '';
1486 my $key = "$hostname|$requri";
1487
(snip)
1496 $cache->set($key, [$timeout, \@headers, $urls]);
1497 }

こうなってる。ここで、

Perlbal -> mod_perl -> MogileFS

こんな風に、フロントに Perlbal, バックエンドに mod_perl ハンドラでも置いて、その裏の MogileFS とやりとり(をあんまさせたくないので Perlbal に直にキャッシュさせたい)という構成を考える。

この場合、

実際にブラウザからアクセスされる URL ... http://example.com/artwork/12345
MogileFS (と mod_perl)から Perlbal に X-REPROXY-URL で返される URL ... http://192.168.0.11:7500/dev1/0/000/000/0000054321.fid
Perlbal がその URL を値としてキャッシュに保存するときの key ... "192.168.0.11|/artwork/12345"

つまり、

X-REPROXY-CACHE-CLEAR: /artwork/12345

というヘッダを mod_perl から Perlbal に返す必要がある(host は補われる)

この /artwork/12345 というリクエスト URL は、 mod_perl 側から直に参照できない。

mod_perl ハンドラを例えば以下のような conf であてていたとすると、

<Location /example/artwork>
SetHandler perl-script
PerlHandler Example::Artwork
</Location>
RewriteEngine On
RewriteRule ^/artwork/(.*) http://127.0.0.1:8080/example/artwork/$1 [P,L]

Perlbal がリクエストされる URL ... http://example.com/artwork/12345
mod_perl が最初にリクエストされる URL ... http://127.0.0.1:8080/artwork/12345
mod_rewrite で書き換えられてハンドラが呼ばれる ... http://127.0.0.1:8080/example/artwork/12345

ここで $r->uri をとると /example/artwork/12345 となり、これをそのまま X-REPROXY-CACHE-CLEAR で返しても Perlbal::Cache がキャッシュした key とは違うものなのでキャッシュを破棄できない。自前で $r->uri を split なりして、 /artwork/12345 を、 Rewrite される前の URL を知る必要がある。当然、どんな RewriteRule かに依存するので一般的な実装はあげられない。 Rewrite しなければもう少し話が簡単になる。

要は、

ブラウザでアクセスする URL ... ブラウザと Perlbal だけが知っている
mod_perl ハンドラが呼ばれる URL ... mod_perl だけが知っている
MogileFS 内のファイル実体を指し示す URL ... MogileFS と、その URL をキャッシュしている Perlbal だけが知っている (.fid)

と、それぞれ意味の違った URL (key になるもの)がいくつか存在して、どれがどれやらわからなくなってしまうので、ハマりどころが多い。ありがちな(というか俺がやった)ミスとしては、 CACHE-FOR でキャッシュした状態で MogileFS からファイル実体を消してしまうと (mogile に突っ込むときの key はまた別に digest とかで作ってあったりすると余計に混乱することうけあい) Mogile にはもう存在せず、したがって mod_perl にはどうしたって知りようがない URL を Perlbal がキャッシュしていて 503 を返しつづける、という状態になってしまう。それから、キャッシュを自発的に消したいときというのはもともとキャッシュしてた URL (Mogile 上でのファイルのありか)が指し示すファイル実体を消したいときなので(実体がないものをいつまでもキャッシュしているのは困る、という理由)当然実体そのものも消すわけだが、

Perlbal のある URL にリクエスト(ある URL に対するキャッシュを消すような mod_perl ハンドラを呼ぶ URL)
mod_perl が MogileFS をコールしてそのファイル実体を消す
消しつつ X-REPROXY-CACHE-CLEAR ヘッダに適した key となる URL を復元してレスポンスヘッダを返す
Perlbal がレスポンスを返しつつ X-REPROXY-CACHE-CLEAR ヘッダを受け取りキャッシュを破棄する

こういう手順でつくらないといけない。この URL は ACL を厳重にしておかないと、全ての artwork に対応するキャッシュ破棄用(つまりファイル削除用) URL を GET されまくってファイルを消されまくってしまうので非常にまずい。

我ながら乱雑で要領を得ない文章だと思うけど、こんなものでもないよりはあったほうがこれから同じことをやろうとする人にとっては多少の助けになると思うので走り書きのままで公開する。こういう、どっかに一言書いてあれば5秒でぐぐって済むことを何時間もかけてやり直すのは人類にとっての時間的損失でばからしいので、適当に間違ってるところとかを修正しつついろんなブログとかに転載しまくって世に広めてください。

Permalink | 記事への反応(0) | 14:38