Exporter のメソッドは次の8個です。最初の3個がパブリックなメソッド、次の3個は内部作業用です。最後の2個はデフォールトのメソッドで Exporter の派生クラスが同名のメソッドを持っていないときに継承して利用されるようです。
sub export sub export_to_level sub import # utility functions sub _push_tags sub export_tags sub export_ok_tags # Default methods sub export_fail sub require_version
export_to_level と import の二つの関数はいずれも export 関数を呼び出していますから、export 関数が Exporter の中心となる関数です。
ここで、perldoc Exporter で Exporter の使い方をもう一度確認します。Exporterの基本的なアイディアは、自分で作成したモジュールをExporterの派生クラスにすることで、自作モジュールのメソッドをmain packageに簡単に導入することができるようになると言うことです。例えば、サンプルモジュール Sample.pm を作成してそのうちのシンボル名A1 - A5をデフォールトで main package に導入し、B1 - B5をオプションで導入できるようにするとします。また、A1 A2 B1 B2 の組と A1 A2 B3 B4 の組はそれぞれ T1 T2 というタグで一度に導入したいとします。この場合 Sample.pm に次のようなコードを挿入します。
package Sample;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(A1 A2 A3 A4 A5);
@EXPORT_OK = qw(B1 B2 B3 B4 B5);
%EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]);
そうすると、 main パッケージに次の三つのようなやり方で 名前 A1 - B5、B1 - B5 を導入することができます。つまり、Sample.pm パッケージで定義した変数名やサブルーチン名をあたかも main package 固有の変数やサブルーチンとして使えるようになります。
1) デフォールトで A1 - A5 を導入する。
package main;
use Sample;
2) 導入する名前を指定する。
package main;
use Sample qw( A1 B2 B5 );
3) タグで組になった名前を導入する。
package main;
use Sample qw( :T2 );
Exporter から派生した Sample.pm があった場合、main パッケージからは、use Sample; または、use Sample qw( LIST ); と記述すると思います。前に述べたように use Sample qw( LIST ); という文の実行は、require Sample; import Module LIST; と同じことなります。Sample には import 関数がありませんから、結局 Module LIST という引数は Exporter の import 関数に渡されることになります。Exporter の import 関数は次のようになります。
sub import {
my $pkg = shift;
my $callpkg = caller($ExportLevel);
export $pkg, $callpkg, @_;
}
$pkg にはパッケージ名 Sample が入ります。$callpkg には caller($Exportlevel) の値が入ります。Exporter のコードの最初の方を見ると、デフォールトでは $ExportLevel = 0 ですから、この場合 $callpkg = caller(0) = 'main' です。( perldoc -f caller 参照。)したがって import 関数は最後の行で、export 'Sample', 'main', LIST; を呼び出すことになります。
上で述べたように use Sample; で呼び出された import 関数からは、export 関数へ 'Sample', 'main', LIST というリストが渡されます。それでは、Exporter の 中心部の export 関数を覗いて見ましょう。export 関数のはじめの部分では、エラーや警告のシグナルが入ったときのエラー処理のコールバックルーチンを一時的に Exporter 用に変更します。
sub export {
# First make import warnings look like they're coming from the "use&quo
t;.
local $SIG{__WARN__} = sub {
my $text = shift;
if ($text =~ s/ at \S*Exporter.pm line \d+.*\n//) {
require Carp;
local $Carp::CarpLevel = 1; # ignore package calling us too.
Carp::carp($text);
}
else {
warn $text;
}
};
local $SIG{__DIE__} = sub {
require Carp;
local $Carp::CarpLevel = 1; # ignore package calling us too.
Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")
if $_[0] =~ /^Unable to create sub named "(.*?)::"/;
};
$SIG{} には、__WARN__ や __SIG__ などのシグナルの割り込みがあったときにそれぞれの処理をするコールバックルーチンへのフックが納められています。例えば __WARN__ シグナルが発生すると、$SIG{__WARN__} でリファレンスされるコールバックルーチンが自動的に呼び出されます。local $SIG{__WARN__} = sub { ... }; という文は $SIG の内容を一時スタックに退避して、新しく sub { ... } で表される無名サブルーチンへのリファレンスを代入するという意味になります。
Perl では局所変数を宣言するのに local と my と言う二つの方法があり、紛らわしいです。大抵の場合 my を使っておけば問題ないでしょう。my で宣言された局所変数は名前テーブルには登録されません。作業が終ったら変数は消滅してしまいます。しかし、local 変数の場合は本質的にはグローバル変数です。もちろん変数の名前テーブルにも登録されます。ただし、local 宣言されているスコープの範囲ではそのもとの値がスタックに退避させられます。コールバックルーチンの処理の場合は $SIG{ } が名前テーブルに登録されている必要があるので local 宣言されているのです。
Perl5 にはリファレンスの機能があります。リファレンスとは、C 言語のポインターのようなもので、データの内容ではなくデータの格納されているアドレスを保持する変数です。たとえば $a = 10; $ref = \$a; print $$ref, "\n"; とすると $$ref で $a の値 10 が表示されます。感覚的には変数 $a の名前の部分 a と $ref が置き換え可能であると考えると便利です。リファレンスは名前のある変数にたいしてだけではなく、無名リストや無名ハッシュへも可能です。例えば次のようになります。$ref1 = [1, 2, 3]; $ref2 = {one => 1, two => 2}。また無名サブルーチンにもリファレンスすることができます。$ref = sub { print "hello\n"; }; このサブルーチンを呼び出すときは、&$ref; とします。
それでは、コールバックルーチンのテストをしてみましょう。まず、次のコードを test_callback.pl の名前で作成してみてください。
#!/usr/bin/perl
while (1) {
print "Please input number > ";
chop( $number = <> );
print 1/$number, "\n";
}
実行結果は次のようになります。
$ perl test_callback.pl Please input number > 1 1 Please input number > 0 Illegal division by zero at test_callback.pl line 7, <> chunk 2.
0 で割算をしようとすると、エラーメッセージが出てプログラムは強制終了されます。今度は上のスクリプトを次のように変更します。
#!/usr/bin/perl
local $SIG{__DIE__} = sub { print "Divsion by zero\n"; goto LABEL; };
while (1) {
LABEL:
print "Please input number > ";
chop( $number = <> );
print 1/$number, "\n";
}
テストしましょう。
$ perl test_callback.pl Please input number > 0 Divsion by zero Please input number > 1 1
今度は 0 の割算が発生しても 'Division by zero' のエラーメッセージを表示するだけでプログラムは止まりません。(終了させるには Ctrl - C を押す必要があります。)
my($pkg, $callpkg, @imports) = @_;
my($type, $sym, $oops);
*exports = *{"${pkg}::EXPORT"};
ここが export 関数の本当のエントリーになります。上で述べたような条件では、引数リスト @_ には 'Sample', 'main', LIST が渡されますから。$pkg = 'Sample'、$callpkg = 'main'、@imports = LIST となります。$type、$sym、$oops は作業用の局所変数です。タイプグロブ *exports は *Sample::EXPORT のエイリアスになります。
if (@imports) {
if (!%exports) {
grep(s/^&//, @exports);
@exports{@exports} = (1) x @exports; # $Sample::EXPORT{A1} = 1, ...
my $ok = \@{"${pkg}::EXPORT_OK"}; # $ok = \@Sample::EXPORT_OK
if (@$ok) {
grep(s/^&//, @$ok);
@exports{@$ok} = (1) x @$ok; # $Sample::EXPORT{B1}=1, ...
}
} # if (!%exports) ブロックの終り
if (@imports) {
で @imports すなわち use Sample から渡された引数リスト LIST があるかどうか判定します。LIST があれば、次のブロックが実行され、LIST が空の場合はそのブロックをスキップします。
if (!%exports) {
ではハッシュ %exports すなわち %Sample::EXPORT がなければ次のブロックを実行します。しかし、perldoc Exporter で Exporter の使い方を調べても %EXPORT と言うのはありません。( @EXPORT はあります)。したがって Sample モジュールにも現れる可能性はありません。謎ですが、use Sample が main パッケージで二回以上実行されるときのことを考えると、二回目以降は、%Sample::EXPORT が存在するので、処理を重複して実行することが避けられます。おそらくそういうことだろうと思いますがコメントがないので推測に過ぎません。ただし、その場合 Sample モジュールが %EXPORT というハッシュを定義していると書き換えられる可能性があり注意しなければなりません。文書化してないのでちょっと気になります。
grep(s/^&//, @exports);
では、@exports すなわち @Sample::EXPORT リストの各要素の先頭に & がついていれば取り除きます。あとの解析でタイプ文字($ @ % など)のついていないシンボル名は全てサブルーチンとして解釈されますから。&つきと&なしの二つの表現が存在するのを避けるための前処理です。
@exports{@exports} = (1) x @exports;
が難解です。@list{@list} の説明については、man perldata として、/days{' で検索すると次のような説明が出てきます。
@days{'a','c'} # same as ($days{'a'},$days{'c'})
つまり、ハッシュ %days の値のリスト( $days{'a'}, $days{'c'} ) を表しています。@list = (1) x @list という見慣れない形式は、man perlop として /_x_ として検索すると次のような説明が見られます。_x_ の両端のアンダースコアーは実際には ' x 'のように両端を空白ではさんだ x を入力してください。
@ones = (5) x @ones; # set all elements to 5
したがって @exports{@exports} = (1) x @exports という暗号のような行は、$exports{ A1 } = 1, $exports{A2} = 1, ... というようにハッシュ %exports に@Sample::EXPORT の各要素をキーとして値が1である要素を追加すると言う意味になります。
同様に以下のコードが実行されると、%exports(%Sample::EXPORT) に @Sample::EXPORT_OK の各要素をキーとして値が 1 である要素を追加します。これによって、@Sample::EXPORT と @Sample::EXPORT_OK にあるシンボル名が全て %exports に登録されます。%exports のキーが export 可能なシンボル名の全てで、それ意外のシンボル名は export されません。%export はこれ以後の処理で、シンボル名が export 可能かどうかを調べるのに使われます。
my $ok = \@{"${pkg}::EXPORT_OK"};
if (@$ok) {
grep(s/^&//, @$ok);
@exports{@$ok} = (1) x @$ok;
次のブロックでは、'Specialized Import List' を使うばあいの引数を解析します。'Specialixed Import List' の説明は perldoc Exporter として、/Specialised Import で検索することができます。
Specialised Import Lists
If the first entry in an import list begins with !, : or /
then the list is treated as a series of specifications
which either add to or delete from the list of names to
import. They are processed left to right. Specifications
are in the form:
[!]name This name only
[!]:DEFAULT All names in @EXPORT
[!]:tag All names in $EXPORT_TAGS{tag} anonymous list
[!]/pattern/ All names in @EXPORT and @EXPORT_OK which match
use 関数から渡された引数リストの先頭の要素が !, : または / で始まっている場合はそのリストは Spedialized Import Lists (特別の導入リスト)として解釈されます。要素の前に ! がついているときはその名称は導入された名前のテーブルから削除されます。: がついているときはタグの名前と解釈されます。/ がついているときは正規表現によるパターンマッチングが行なわれます。
if ($imports[0] =~ m#^[/!:]#){
my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
my $tagdata;
my %imports;
my($remove, $spec, @names, @allexports);
# negated first item implies starting with default set:
unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;
if ($imports[0] =~ m#^[/!:]#){
では、@imports の先頭の要素( use から渡された引数リスト LIST の先頭の要素)が / や ! や : の時は次のブロックが実行されます。
my $tagsref = \%{"${pkg}::EXPORT_TAGS"};
で、$tagsref には %Sample::EXPORT_TAGS のリファレンスが代入されます。my $tagdata ... my($remove ... ); までは局所変数の宣言です。
unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/;
@imports の先頭の要素が ! (名前の削除)で始まっている場合は、デフォールトの名前リストをあらかじめ導入しておく意味で ':DEFAULT' を @imports の先頭に追加します。
foreach $spec (@imports){
foreach で $spek に @imports の要素( use から渡された LIST の要素) をひとつずつ取り出して次のブロックで解析します。
$remove = $spec =~ s/^!//;
で、$spec の先頭が ! の場合は ! を取り去った名前を $remove に代入します。
if ($spec =~ s/^://){
$sepc の先頭が : の場合、$spec から : を取り除いて次の処理を行ないます。
if ($spec eq 'DEFAULT'){
@names = @exports;
}
では、$spec = 'DEFAULT' だったら @names = @Sample::EXPORT としてタグで導入するシンボル名のリスト @names 内容は @Sample::EXPORT のものと同じにします。この文の if から始まって elsif ... elsif ... と続きますから、$spec の語解析処理がしばらく続きます。したがって $spec が DEFAULT であれば、これ以降の elsif .. elsif .. else の処理はスキップされます。
elsif ($tagdata = $tagsref->{$spec}) {
@names = @$tagdata;
}
では、elsif ですから、$spec = 'DEFAULT' ではない場合の処理です。$spec に入っているタグの名前に対応する名前リストを %Sample::EXPORT_TAGS から引き出して @names にいれます。$spec が%Sample::EXPORT_TAGS のキーになければ $tagdata = undef になりますから、@names = @$tagdata は実行されません。
else {
warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];
++$oops;
next;
}
%Sample::Export_TAG に登録されていないタグが使われた場合は、エラーメッセージが表示され、$oops がインクリメントされます。また、next があるので、この行以下の処理を跳ばして foreach ループのブロックの最後に jump します。
elsif ($spec =~ m:^/(.*)/$:){
my $patn = $1;
@allexports = keys %exports unless @allexports; # only do keys once
@names = grep(/$patn/, @allexports); # not anchored by default
}
これは、$spec が両端を / で囲まれている正規表現の形をとっている場合です。先ず $patn に正規表現を代入しておきます。次に @allexports に %exports (%Sample::EXPORT) のキーのリストを代入します。最後に @names リストに @allexports のうち $patn に一致するものを代入します。
else {
@names = ($spec); # is a normal symbol name
}
は $spec が通常の名前の場合です。単に @names リストに ($spec) リストを代入します。
warn "Import ".($remove ? "del":"add").": @names "
if $Verbose;
$Verbose が真の場合は、確認のメッセージとして、導入( add )または削除( delete )した名前(のリスト)を表示します。
if ($remove) {
foreach $sym (@names) { delete $imports{$sym} }
}
$remove が空でない場合は、@names の要素をキーとする %imports の要素を取り除きます。
else {
@imports{@names} = (1) x @names;
}
$remove が空の場合は、@names の要素をキーとし値が 1 である要素を %imports に追加します。
} # foreach $spec (@imports) ブロックの終り
@imports = keys %imports;
}
@imports リストの 要素が全て解析されたら、@imports に %imports のキーのリストを代入します。ここで @imports の内容が use から渡された LIST ではなくて、%imports のキーのリストに変わるので注意が必要です。@imports の内容が最終的に export されるシンボル名のリストになります。
foreach $sym (@imports) {
@imports の個々の要素を $sym に代入して、$sym について以下の処理をします。
if (!$exports{$sym}) {
%exports に $sym をキーとする要素が登録されれていない場合に、以下の処理をします。
if ($sym =~ m/^\d/) {
$sym = <数字>の場合は以下の処理が行なわれます。
$pkg->require_version($sym);
ここではSample->require_version( <バージョンナンバー> )を呼び出します。Sample パッケージに require_version メソッドがなければ、Exporter の require_version メソッドが継承されて呼び出されます。
# If the version number was the only thing specified
# then we should act as if nothing was specified:
if (@imports == 1) {
@imports = @exports;
last;
}
@imports の要素がひとつだけの場合は、use Sample <バージョンナンバー> という使い方をしてあるので、@imports に @exports をそのまま代入します。last という命令は perldoc -f last で調べると、次のようになります。
$ perldoc -f last =item last LABEL =item last The Ccommand is like the C statement in C (as used in loops); it immediately exits the loop in question. If the LABEL is omitted, the command refers to the innermost enclosing loop. The C block, if any, is not executed: LINE: while ( ) { last LINE if /^$/; # exit when done with header ... }
C 言語の break と一緒でループを抜け出す命令のようです。
# We need a way to emulate 'use Foo ()' but still
# allow an easy version check: "use Foo 1.23, ''"\
;
if (@imports == 2 and !$imports[1]) {
@imports = ();
last;
}
use Sample <バージョンナンバー>, '' と言う使い方をした場合の処理です。つまり、@imports の要素数が 2 で、第2引数が '' になる場合です。この場合 @imports を空にします。
} elsif ($sym !~ s/^&// || !$exports{$sym}) {
require Carp;
Carp::carp(qq["$sym" is not exported by the $pkg \
module]);
$oops++;
}
} # if (!%exports{&sym}) ブロックの終り
} # foreach $sym (@imports) ブロックの終り
$sym の & を取り去った後が空になったり、$exports{ $sym } の値が 0 だったりした場合はエラーなので、エラーメッセージを表示します。
if ($oops) {
require Carp;
Carp::croak("Can't continue after import errors");
}
} # if (@imports) ブロックの終り
$oops の値が 0 でない場合はエラーが発生しているのでエラーメッセージを表示してプログラムを強制終了します。
else {
@imports = @exports; # @imports が空リストのとき。
}
else は if (@imports) に対応しますから。この場合は @imports が空リストの場合。つまり、use Sample; のように use に LIST 引数が渡されなかった場合の処理です。この場合は @imports = @exports として、%EXPORT のリストが @import に代入されます。
*fail = *{"${pkg}::EXPORT_FAIL"};
*fail を *Sample::EXPORT_FAIL のエイリアスにします。
if (@fail) {
シンボル(名前)の import に失敗した場合は次の処理をします。
if (!%fail) {
# Build cache of symbols. Optimise the lookup by adding
# barewords twice... both with and without a leading &.
# (Technique could be applied to %exports cache at cost of memory)
my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @fail;
warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Verbose;
@fail{@expanded} = (1) x @expanded;
}
%fail の内容が空の場合(シンボル名が正当なものだった場合)はシンボルのキャッシュを作ります。裸のシンボルとそのシンボルの先頭に $ をつけたものの両方をキャッシュにおくことによって、検索を最適化することができます。同じテクニックは %exports にも適用できますが、メモリーを消費します。
ここでは、@fail の各要素について、先頭の $ のあるものとないものを、@expanded に代入します。次に $Verbous が真であれば、エラーメッセージを表示します。最後に %fail の各要素の値を 1 にします。
my @failed;
foreach $sym (@imports) { push(@failed, $sym) if $fail{$sym} }
@imports の各要素を $sym (symbol の略) に代入し、$fail{ $sym } が存在していれば @failed リストの先頭に $sym を追加する。
if (@failed) {
@failed が空でなければ以下のエラー処理を行なう
@failed = $pkg->export_fail(@failed);
@failed = $Sample->export_fail(@failed) 関数を呼び出します。Sample モジュールに export_fail 関数がなければ、Exporter モジュールの同名の関数が利用されます。default の export_fail 関数のコードは次のようになります。
sub export_fail {
my $self = shift;
@_;
}
これは、@_ から、パッケージ名を取り除いて残りの @_ を返すわけですから。結局何もしないサブルーチンです。export_fail は派生クラスでオーバーライドするために用意されたメソッドのようです。
foreach $sym (@failed) {
require Carp;
Carp::carp(qq["$sym" is not implemented by the $pkg m\
odule ],
"on this architecture");
}
@failed の個々の要素についてエラーメッセージを出力する
if (@failed) {
require Carp;
Carp::croak("Can't continue after import errors");
}
}
}
@failed が空でない場合は import error であることを表示してプログラムを強制終了する。
warn "Importing into $callpkg from $pkg: ",
join(", ",sort @imports) if $Verbose;
$Verbous が真なら 'Importing into main from Sample:
foreach $sym (@imports) {
@imports の各要素を $sym に代入し以下の処理を行ないます。シンボルの import の中心になる部分です。
# shortcut for the common case of no type character
(*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, ne\
xt)
unless $sym =~ s/^(\W)//;
先頭にタイプ文字のついていないシンボルは Sample パッケージのメソッドと考えてエイリアスを作ります。*main::METHOD=\&Sample::METHOD が実行されて &main::METHOD が &Sample::METHOD のエイリアスになります。したがって、main パッケージで &METHOD を呼び出すと、&Sample::METHOD が呼び出されます。$sym =~ s/^\W//; では、先頭の非アスキー文字(タイプ文字)が $1 に代入され、 $sym からはタイプ文字が削除されます。
$type = $1;
*{"${callpkg}::$sym"} =
$type eq '&' ? \&{"${pkg}::$sym"} :
$type eq '$' ? \${"${pkg}::$sym"} :
$type eq '@' ? \@{"${pkg}::$sym"} :
$type eq '%' ? \%{"${pkg}::$sym"} :
$type eq '*' ? *{"${pkg}::$sym"} :
do { require Carp; Carp::croak("Can't export symbol: $type$sym\
") };
}
}
タイプ指定のあるシンボルはそのタイプ別に *main::SYMBOL=\$Sample::SYMBOL という形でそれぞれのエイリアスを作ります。これでやっと export メソッド全てを解読できました。export メソッドの前半の大半の部分は引数の構文解析に使われています。自分でパッケージを作る際も多かれ少なかれ同様の処理になりそうなので勉強になります。上記の解読についてはあまり自信がないので、ここはおかしいぞと言うところがあればメールか掲示番で教えてください。