perltie - オブジェクトクラスを単純な変数に隠す方法
tie VARIABLE, CLASSNAME, LIST
$object = tied VARIABLE
untie VARIABLE5.0 より前の Perl では、プログラマは dbmopen() を使ってディスクにある 標準 UNIX dbm(3x) フォーマットのデータベースをプログラム中の %HASH と 結び付けることができました。 しかしながら、Perl は特定の dbm ライブラリか別のものを使って ビルドすることができたものの、両方一度にはできませんでした。 そして、この仕組みを他のパッケージや変数の型に拡張することは できなかったのです。
今はできます。
tie() 関数は変数と、その変数に対するアクセスメソッドの実装を提供する クラス(パッケージ)とを結び付けます。 この魔法が一度働けば、tie された変数は自動的に適切なクラスにある メソッド呼び出しを実行します。 クラスのすべての複雑性はメソッド呼び出しに隠されます。 それらのメソッドの名前は、BEGIN() や END() と同様に(そのメソッドを) Perl が こっそりと呼び出すことを示すための規約に従って全て大文字です。
tie() コールの中で、VARIABLE は魔法を掛けられる変数の名前です。 CLASSNAME は正しい型のオブジェクトを実装するクラスの名前です。 LIST にあるその他の引数はクラスの適切なコンストラクタメソッド TIESCALAR()、TIEARRAY()、TIEHASH()、TIEHANDLE() のいずれかに 渡されます(典型的にはこれらの引数は C の dbminit() 関数に渡すのと 同じものです)。 "new" メソッドから返されたオブジェクトは同様に関数 tie() からも 返されます。 これはあなたが CLASSNAME の中の別のメソッドでアクセスしたいというときに 便利でしょう(あなたは実際には正しい「型」(HASH か CLASSNAME) の 参照を、それが適切な bless されたオブジェクトであるということから 返す必要はありません)。 また、関数 tied() を使って、基礎となるオブジェクトへのリファレンスを 取得することができます。
dbmopen() とは異なり、tie() はモジュールを use したり require したり することはありません。 あなたが、自分自身でそれを明示的に行わなければなりません。
tie されたスカラを実装するクラスは、TIESCALAR, FETCH, STORE, そして可能であれば UNTIE や DESTROY といったメソッドを定義しておくべきです。
以下のような操作を、ユーザーに許しているスカラに対してクラスを tie する例を使って順に見て行きましょう。
tie $his_speed, 'Nice', getppid();
tie $my_speed, 'Nice', $$;こうした後ではこれらの変数のいずれかがアクセスされたときには、カレントの システム優先順位が取得されたり返されたりします。 もし変数に代入が行われれば、プロセスの優先順位は変更されます!
システムの PRIO_PROCESS, PRIO_MIN, PRIO_MAX といった定数に アクセスするために Jarkko Hietaniemi <jhi@iki.fi> の BSD::Resource クラスを使います。 以下はこのクラスの前置きです。
package Nice;
use Carp;
use BSD::Resource;
use strict;
$Nice::DEBUG = 0 unless defined $Nice::DEBUG;これはクラスのためのコンストラクタです。 その役割は作成された新たな(おそらくは無名の)スカラへの bless された 参照を返すことです。 たとえば、
sub TIESCALAR {
my $class = shift;
my $pid = shift || $$; # 0 means me
if ($pid !~ /^\d+$/) {
carp "Nice::Tie::Scalar got non-numeric pid $pid" if $^W;
return undef;
}
unless (kill 0, $pid) { # EPERM or ERSCH, no doubt
carp "Nice::Tie::Scalar got bad pid $pid: $!" if $^W;
return undef;
}
return bless \$pid, $class;
}このtie クラスでは、コンストラクタが失敗したときに例外を起こすのではなく エラーを返すことを選択しました。 dbmopen() が動作している間に、他のクラスは例外が起きることを 好まないかもしれないからです。 グローバル変数 $^W でエラーメッセージを出すかどうかを検査しています。
このメソッドは tie された変数がアクセス(読み出し)される度に起動されます。 これは自分のリファレンス、つまり私たちが扱おうとしている スカラを表現するオブジェクトの他に引数は取りません。 この場合、単に SCALAR の参照をtieされたスカラオブジェクトとして 使うので、単純な $$self がそこに格納されている実際の値を取得する メソッドとなります。 以下に示した例では、実際の値は変数に tie されたプロセス ID です。
sub FETCH {
my $self = shift;
confess "wrong type" unless ref $self;
croak "usage error" if @_;
my $nicety;
local($!) = 0;
$nicety = getpriority(PRIO_PROCESS, $$self);
if ($!) { croak "getpriority failed: $!" }
return $nicety;
}ここでは、renice に失敗した場合には例外を引き起こすようにしました。 エラーを返すための場所がなく、例外を引き起こすことがおそらく妥当です。
このメソッドは tie された変数に代入される度毎に起動されます。 自分の参照のほか、ただ一つの引数としてユーザーが代入しようとする 新しい値を取ります。 STORE から返される値は気にしないで下さい -- 代入された値を返す代入の動作は FETCH で実装されています。
sub STORE {
my $self = shift;
confess "wrong type" unless ref $self;
my $new_nicety = shift;
croak "usage error" if @_;
if ($new_nicety < PRIO_MIN) {
carp sprintf
"WARNING: priority %d less than minimum system priority %d",
$new_nicety, PRIO_MIN if $^W;
$new_nicety = PRIO_MIN;
}
if ($new_nicety > PRIO_MAX) {
carp sprintf
"WARNING: priority %d greater than maximum system priority %d",
$new_nicety, PRIO_MAX if $^W;
$new_nicety = PRIO_MAX;
}
unless (defined setpriority(PRIO_PROCESS, $$self, $new_nicety)) {
confess "setpriority failed: $!";
}
}このメソッドは、untie が発生すると起動されます。 これは、クラスが、もはや呼び出されなくなるのはいつかを知る必要がある場合に 便利です。 (もちろん DESTROY を除いてです。) さらなる詳細については後述する "The untie Gotcha" を参照してください。
このメソッドは tie された変数を破棄する必要があるときに起動されます。 他のオブジェクトクラスと同じように、このようなメソッドは ほとんど必要ありません。 それは、Perl は消滅しかかったオブジェクトのメモリを自動的に 解放するからです。 これは C++ ではないのです。 いいですね?。 私たちはここでは DESTROY メソッドをデバッグのためだけに使います。
sub DESTROY {
my $self = shift;
confess "wrong type" unless ref $self;
carp "[ Nice::DESTROY pid $$self ]" if $Nice::DEBUG;
}これがすべきことの全てです。 実際のところ、それよりも多くのことがあります。 ですから、私たちはここでちょっとした完全性、堅牢性、一般的な美しさと いうものを込めました。 もっと簡単な TIESCALAR クラスを作ることも可能です。
tie された配列を実装するクラスは TIEARRAY, FETCH, STORE, FETCHSIZE, STORESIZE、そしておそらく UNTIE や DESTROY といったメソッドを 実装すべきでしょう。
FETCHSIZE と STORESIZE は $#array と scalar(@array) アクセスに等価なものを提供します。
POP, PUSH, SHIFT, UNSHIFT, SPLICE, DELETE, EXIST といったメソッドは 同名の perl の演算子(ただし小文字)が tie された配列に対して 操作を行うときに必要となります。 Tie::Array クラスは、これらのうち、最初の 5 つの基本的なメソッドを 実装するための基底クラスとして使用できます。 Tie::Array での DELETE と EXISTS のデフォルトの実装は 単なる croak です。
それに加え、EXTEND は perl が実際の配列中であらかじめ 拡張するようなときに呼び出されます。
ここでの説明のため、要素数が生成時に固定されたサイズである配列を実装します。 固定サイズを越えた要素を作ろうとすると、例外が発生します。 例えば:
use FixedElem_Array;
tie @array, 'FixedElem_Array', 3;
$array[0] = 'cat'; # ok.
$array[1] = 'dogs'; # exception, length('dogs') > 3.このクラスに対する 前置きコードは以下の通りです。
package FixedElem_Array;
use Carp;
use strict;これはクラスのためのコンストラクタです。 その役割は作成された新たな(おそらくは無名の配列の参照)配列への bless された参照を返すことです。
私たちの例では、あなたにあなたが 実際には ARRAY のリファレンスを 返さなくてもよいということを示すためだけに、使用するオブジェクトを 表わす HASH の参照を選びました。 HASH は汎用的なレコード型と同じように働きます。 {ELEMSIZE} フィールドは許される最大の要素の数を格納し、 {ARRAY} フィールドは本物の ARRAY のリファレンスを保持します。 誰かがクラスの外側で返されたオブジェクトのデリファレンスを試みた場合 (それが ARRAY のリファレンスであると疑いなく考えて)、それは失敗します。 これはあなたがオブジェクトのプライバシーを尊重すべきであるという ことなのです。
sub TIEARRAY {
my $class = shift;
my $elemsize = shift;
if ( @_ || $elemsize =~ /\D/ ) {
croak "usage: tie ARRAY, '" . __PACKAGE__ . "', elem_size";
}
return bless {
ELEMSIZE => $elemsize,
ARRAY => [],
}, $class;
}このメソッドは tie された配列の個々の要素がアクセス(読み出し)される毎に 起動されます。 これは自分の参照のほかに、一つの引数、フェッチしようとする値の インデックスをとります。
sub FETCH {
my $self = shift;
my $index = shift;
return $self->{ARRAY}->[$index];
}配列からの読み込みに負数の添え字が使われると、添え字は FETCH に渡される前に FETCHSIZE を呼び出すことで正の数に変換されます。 tie された配列クラスの $NEGATIVE_INDICES に真の値を代入することで この機能を無効にできます。
すでに気がついたかもしれませんが、FETCH メソッド(など)の名前は全ての アクセスについて、たとえコンストラクタが別の名前であった (TIESCALAR と TIEARRAY)としても同じ名前になっています。 理論的には、幾つかの tie されたクラスをサービスする同じクラスを 持つこともできるでしょうが、実際にはこれは厄介なものになり、 単にクラスあたり一つの状態にするのが最も簡単です。
このメソッドは、tie された配列にある要素に対する書き込みがある度毎に 起動されます。 これは自分の参照のほかに、何かを格納しようとする場所の添え字と、 格納しようとしている値という二つの引数を取ります。
この例では、undef は実際は $self->{ELEMSIZE} 個の空白なので、 ここでもう少し作業が必要です:
sub STORE {
my $self = shift;
my( $index, $value ) = @_;
if ( length $value > $self->{ELEMSIZE} ) {
croak "length of $value is greater than $self->{ELEMSIZE}";
}
# fill in the blanks
$self->EXTEND( $index ) if $index > $self->FETCHSIZE();
# right justify to keep element size for smaller elements
$self->{ARRAY}->[$index] = sprintf "%$self->{ELEMSIZE}s", $value;
}インデックスの値が負数の場合、FETCH と同様に扱われます。
オブジェクト this と結び付けられた tie された配列の合計要素数を返します。 (scalar(@array) と等価です)。 例えば:
sub FETCHSIZE {
my $self = shift;
return scalar @{$self->{ARRAY}};
}オブジェクト this に結び付けられた tie された配列のアイテムの合計数を count にセットします。 もし配列がより大きくなるなら、新しい位置ではクラスのマッピングは undef を返すべきです。 もし配列がより小さくなるなら、count を超えたエントリは削除されるべきです。
この例では、'undef' というのは実際には $self->{ELEMSIZE} 個の空白を 含む要素です。 これを見てください:
sub STORESIZE {
my $self = shift;
my $count = shift;
if ( $count > $self->FETCHSIZE() ) {
foreach ( $count - $self->FETCHSIZE() .. $count ) {
$self->STORE( $_, '' );
}
} elsif ( $count < $self->FETCHSIZE() ) {
foreach ( 0 .. $self->FETCHSIZE() - $count - 2 ) {
$self->POP();
}
}
}配列が、count エントリに大きくなりそうだということを通知する 呼び出しです。 割り当ての最適化に使えます。 このメソッドで何かをしなければならないということはありません。
例では、空白 (undef) のエントリがないことを確実にしたいので、 EXTEND は必要に応じて要素を埋めるために STORESIZE を使います:
sub EXTEND {
my $self = shift;
my $count = shift;
$self->STORESIZE( $count );
}tie された配列 this にインデックスが key である要素が存在するかを 検証します。
この例では、要素が $self->{ELEMSIZE} 個の空白のみで構成されていれば、 これは存在しません:
sub EXISTS {
my $self = shift;
my $index = shift;
return 0 if ! defined $self->{ARRAY}->[$index] ||
$self->{ARRAY}->[$index] eq ' ' x $self->{ELEMSIZE};
return 1;
}インデックス key の要素を tie された配列 this から削除します。
この例では、削除された要素は $self->{ELEMSIZE} 個の空白です:
sub DELETE {
my $self = shift;
my $index = shift;
return $self->STORE( $index, '' );
}オブジェクト this に関連付けられた tie された配列から全ての値を 削除します。 例えば:
sub CLEAR {
my $self = shift;
return $self->{ARRAY} = [];
}LIST の要素を配列に追加します。 例えば:
sub PUSH {
my $self = shift;
my @list = @_;
my $last = $self->FETCHSIZE();
$self->STORE( $last + $_, $list[$_] ) foreach 0 .. $#list;
return $self->FETCHSIZE();
} 配列の最後の要素を取り除いてそれを返します。 例えば:
sub POP {
my $self = shift;
return pop @{$self->{ARRAY}};
}配列の最初の要素を取り除いて(残りの要素はシフトします)、その要素を返します。 例えば:
sub SHIFT {
my $self = shift;
return shift @{$self->{ARRAY}};
}LIST 要素を配列の先頭に挿入し、すでにある要素は場所を空けるために 移動します。 例えば:
sub UNSHIFT {
my $self = shift;
my @list = @_;
my $size = scalar( @list );
# make room for our list
@{$self->{ARRAY}}[ $size .. $#{$self->{ARRAY}} + $size ]
= @{$self->{ARRAY}};
$self->STORE( $_, $list[$_] ) foreach 0 .. $#list;
}配列に対する splice と等価に振る舞います。
offset はオプションでデフォルトは 0 です; 負数は配列の最後からの 位置を示します。
length はオプションで、デフォルトは配列の残りです。
LIST は空かもしれません。
元の、offset の位置から length 要素分のリストを返します。
この例では、LIST がある場合は少し近道をします:
sub SPLICE {
my $self = shift;
my $offset = shift || 0;
my $length = shift || $self->FETCHSIZE() - $offset;
my @list = ();
if ( @_ ) {
tie @list, __PACKAGE__, $self->{ELEMSIZE};
@list = @_;
}
return splice @{$self->{ARRAY}}, $offset, $length, @list;
}untie が起きると呼び出されます。 (後述する "The untie Gotcha" を参照してください。)
このメソッドは tie された変数を破棄する必要があるときに呼び出されます。 スカラを tie したクラスと同様、このメソッドはガベージコレクションを 言語自体が行っているのでほとんど必要ありません。 ですから、今回はこのまま放っておきます。
ハッシュは tie される最初の Perl データ型でした(dbmopen() を参照)。 tie されたハッシュを実装するクラスは、以下のメソッドを定義すべきです。 TIEHASH はコンストラクタです。 FETCH と STORE はキーと値のペアにアクセスします。 EXIST はキーがハッシュにあるかどうかを報告し、DELETE はキーを削除します。 CLEAR はすべてのキーと値のペアを削除することによりハッシュを空にします。 FIRSTKEY と NEXTKEY は全てのキーを反復するための関数 keys() と each() を 実装します。 SCALAR は tie されたハッシュがスカラコンテキストで評価されたときに 呼び出されます。 UNTIE は untie が起きたときに呼び出され、DESTROY は tie された変数が ガーベジコレクションされるときに呼び出されます。
もしこれがたくさんありすぎると感じられるのなら、標準の Tie::StdHash モジュールを単純に継承し、再定義を必要とするものだけを自分で 実装することもできます。 詳しくは Tie::Hash を参照してください。
Perl がハッシュに存在していないキーと、ハッシュに存在しているけれども undef という値を持っているキーとを明確に区別しているということを 忘れないでください。 これら二つの可能性は、exists() と defined() という関数を使って検査できます。
次の例は tie されたハッシュクラスを使ったものです。 この例では特定のユーザーのドットファイルを表わすハッシュを提供します。 あなたはハッシュをファイルの名前(からドットを取り除いたもの)によって 添え字付けを行い、そのドットファイルの内容を取得します。 例えば:
use DotFiles;
tie %dot, 'DotFiles';
if ( $dot{profile} =~ /MANPATH/ ||
$dot{login} =~ /MANPATH/ ||
$dot{cshrc} =~ /MANPATH/ )
{
print "you seem to set your MANPATH\n";
}tie されたクラスを使ったもう一つの例です。
tie %him, 'DotFiles', 'daemon';
foreach $f ( keys %him ) {
printf "daemon dot file %s is size %d\n",
$f, length $him{$f};
}この DotFiles という tie されたハッシュでは、私たちは {LIST} フィールドのみをユーザーが本当のハッシュであると考えるであろう幾つかの 重要なフィールドを持ったオブジェクトのために、通常のハッシュを 使いました。
このオブジェクトが表わしているドットファイルの所有者
ドットファイルがある場所
これらのドットファイルを変更したり削除することをしようとすべきか を表わすフラグ
ドットファイルの名前と内容のマッピングをしたハッシュ
次は Dotfiles.pm の先頭です:
package DotFiles;
use Carp;
sub whowasi { (caller(1))[3] . '()' }
my $DEBUG = 0;
sub debug { $DEBUG = @_ ? shift : 1 }この例では、私たちは開発の間トレースがしやすいようにデバッグ情報を 出力できるようにしたいと考えました。 同様に、警告を出力するのを助ける一つの便利な内部関数を残しました。 whowasi() は呼び出した関数の名前を返します。
以下は、DotoFiles に tie されたハッシュのためのメソッドです。
これはクラスに対するコンストラクタです。 その役割は、アクセスされる(おそらくは無名のハッシュ、 ただしそうする必要はない)オブジェクトへの bless された参照を返すことです。
コンストラクタの例です。
sub TIEHASH {
my $self = shift;
my $user = shift || $>;
my $dotdir = shift || '';
croak "usage: @{[&whowasi]} [USER [DOTDIR]]" if @_;
$user = getpwuid($user) if $user =~ /^\d+$/;
my $dir = (getpwnam($user))[7]
|| croak "@{[&whowasi]}: no user $user";
$dir .= "/$dotdir" if $dotdir;
my $node = {
USER => $user,
HOME => $dir,
LIST => {},
CLOBBER => 0,
};
opendir(DIR, $dir)
|| croak "@{[&whowasi]}: can't opendir $dir: $!";
foreach $dot ( grep /^\./ && -f "$dir/$_", readdir(DIR)) {
$dot =~ s/^\.//;
$node->{LIST}{$dot} = undef;
}
closedir DIR;
return bless $node, $self;
}readdir が返した値をつかってファイルテストをしようという場合、 問い合わせにディレクトリを付加すべきでしょう。 そうしなければ、chdir() をしていないので間違ったファイルを テストしてしまうこととなります。
このメソッドは tie されたハッシュがアクセス(読み出し)される度毎に 呼び出されます。 これは自分の参照のほかに、フェッチしようとしている値に対するキーを、 ただ一つの引数としてとります。
以下に示すのは、私たちの DotFiles サンプルのためのフェッチです。
sub FETCH {
carp &whowasi if $DEBUG;
my $self = shift;
my $dot = shift;
my $dir = $self->{HOME};
my $file = "$dir/.$dot";
unless (exists $self->{LIST}->{$dot} || -f $file) {
carp "@{[&whowasi]}: no $dot file" if $DEBUG;
return undef;
}
if (defined $self->{LIST}->{$dot}) {
return $self->{LIST}->{$dot};
} else {
return $self->{LIST}->{$dot} = `cat $dir/.$dot`;
}
}UNIX の cat(1) コマンドを呼んでいるので記述するのは簡単でしたが、 ファイルを自分でオープンすることによってよりポータブル(かつ、より高効率)に できます。 もちろん、ドットファイルは UNIX 的なコンセプトですから、 私たちは気にしませんでした。
このメソッドは tie されたハッシュの要素がセット(書き込み)される度に 呼び出されます。 これは自分の参照の他に二つの引数、何かを格納しようとする場所の添え字と、 格納しようとする値をとります。
以下は DotFiles のサンプルです。 tie() で返されたオブジェクトのリファレンス上で clobber() メソッドが 呼び出されない限り、ファイルを上書きしないようにしています。
sub STORE {
carp &whowasi if $DEBUG;
my $self = shift;
my $dot = shift;
my $value = shift;
my $file = $self->{HOME} . "/.$dot";
my $user = $self->{USER};
croak "@{[&whowasi]}: $file not clobberable"
unless $self->{CLOBBER};
open(F, "> $file") || croak "can't open $file: $!";
print F $value;
close(F);
}もし何かを変更したいというのであれば、このようにします。
$ob = tie %daemon_dots, 'daemon';
$ob->clobber(1);
$daemon_dots{signature} = "A true daemon\n";基礎をなすオブジェクトへの参照を扱うもう一つの方法は tied() 関数を 使うことで、これによって clobber を以下の様に使ってセットできます。
tie %daemon_dots, 'daemon';
tied(%daemon_dots)->clobber(1);clobber メソッドは単純です。
sub clobber {
my $self = shift;
$self->{CLOBBER} = @_ ? shift : 1;
}このメソッドはハッシュから要素を取り除くとき、典型的には delete() 関数を 使ったときに呼び出されます。 繰り返しますが、本当にファイルを clobber したいのかを注意深く検査しています。
sub DELETE {
carp &whowasi if $DEBUG;
my $self = shift;
my $dot = shift;
my $file = $self->{HOME} . "/.$dot";
croak "@{[&whowasi]}: won't remove file $file"
unless $self->{CLOBBER};
delete $self->{LIST}->{$dot};
my $success = unlink($file);
carp "@{[&whowasi]}: can't unlink $file: $!" unless $success;
$success;
}DELETE の 返す値は delete() の戻り値から来ています。 もしあなたが通常の delete() の動作をまねしたいというのであれば、 FETCH がこのキーに対して返すであろう値を返すべきでしょう。 この例では、戻り値としてファイルの削除に成功したかどうかを 返すことを選択しました。
このメソッドはハッシュ全体が消去されるとき、通常は空リストが代入されたときに 呼び出されます。
私たちの例では、これはユーザーのすべてのドットファイルを 削除してしまいます! これはとても危険なことで、実際に削除するには CLOBBER に 1 を超える値を セットすることが必要となります。
sub CLEAR {
carp &whowasi if $DEBUG;
my $self = shift;
croak "@{[&whowasi]}: won't remove all dot files for $self->{USER}"
unless $self->{CLOBBER} > 1;
my $dot;
foreach $dot ( keys %{$self->{LIST}}) {
$self->DELETE($dot);
}
}このメソッドは特定のハッシュにおいて、exists() 関数が使われたときに 呼び出されます。 私たちの例では、このためにハッシュ要素 {LIST} を参照します。
sub EXISTS {
carp &whowasi if $DEBUG;
my $self = shift;
my $dot = shift;
return exists $self->{LIST}->{$dot};
}このメソッドは keys() や each() を呼び出すのと同様に、ハッシュを通じた 反復をユーザーが行おうとするときに呼び出されます。
sub FIRSTKEY {
carp &whowasi if $DEBUG;
my $self = shift;
my $a = keys %{$self->{LIST}}; # reset each() iterator
each %{$self->{LIST}}
}このメソッドは keys() または each() 反復の間に呼び出されます。 二番目の引数として、最後にアクセスしたキーをとります。 これは、あなたが順番に取り出すとか、二度以上反復子を呼び出したり、 あるいは実際にはハッシュのどこにも格納されていないものであるときに 便利です。
私たちの例では本当のハッシュを使うので、やることは簡単です。 しかし、LIST フィールドを間接的に扱わなければなりません。
sub NEXTKEY {
carp &whowasi if $DEBUG;
my $self = shift;
return each %{ $self->{LIST} }
}これはハッシュがスカラコンテキストで評価されたときに呼び出されます。 tie されていないハッシュの振る舞いを真似るために、tie されたハッシュが空と 考えられる場合は、このメソッドは偽の値を返すべきです。 このメソッドが存在しない場合、perl はいくらかの教育された推測を行い、 ハッシュが反復中である場合は真を返します。 もしそうでない場合は、FIRSTKEY が呼び出され、これが空リストを返した場合は 偽の値を返し、さもなければ真の値を返します。
しかし、perl が常に正しいことを行うと盲目的に信頼しては いけません。 特に、ハッシュが空になるまで繰り返し DELETE を呼び出すことでハッシュを クリアした場合、perl は間違って真を返します。 従って、ハッシュがスカラコンテキストでもうまく振舞うことを完全に確実に したい場合は、独自の SCALAR メソッドを作ることを勧めます。
この例では、$self->{LIST} でリファレンスされている、元となる ハッシュで scalar を呼び出しています:
sub SCALAR {
carp &whowasi if $DEBUG;
my $self = shift;
return scalar %{ $self->{LIST} }
}これは untie が発生した時に呼び出されます。 以下の "The untie Gotcha" を参照してください。
このメソッドは tie されたハッシュがスコープの外に出るときに 呼び出されます。 実際には、デバッグ情報を足そうとするとか、後始末のための 補助的な情報を持っていなければ、必要になりません。
sub DESTROY {
carp &whowasi if $DEBUG;
}keys() や values() といった関数は、DBM ファイルのような大きなオブジェクトに 対して使ったときに大きなリストを返す可能性があるということに 注意してください。 そういったものに対して繰り返しの処理を行うには、each() を使うのが 良いでしょう。 例:
# print out history file offsets
use NDBM_File;
tie(%HIST, 'NDBM_File', '/usr/lib/news/history', 1, 0);
while (($key,$val) = each %HIST) {
print $key, ' = ', unpack('L',$val), "\n";
}
untie(%HIST);これは現時点ではまだ部分的にしか実装されていません。
tie されたファイルハンドルを実装するクラスは以下のメソッドを定義すべきです。 TIEHANDLE と、PRINT, PRINTF, WRITE, READLINE, GETC, READ の 中の少なくともいずれか一つ、そして可能であればCLOSE, UNTIE, DESTROY。 また、クラスは以下のものも提供できます: BINMODE, OPEN, EOF, FILENO, SEEK, TELL - もし対応する perl の演算子がハンドルで つかわれるならです。
STDERR が tie されると、その PRINT メソッドが、警告とエラーのメッセージを 出力するために呼び出されます。 この機能は呼び出しの最中には一時的に無効にされているので、再帰ループを 作ることなく PRINT の内部で warn() を使えることを意味します。 また、__WARN__ や __DIE__ のハンドラと同様に、STDERR の PRINT メソッドはパーサーエラーの報告に呼び出されるので、"%SIG" in perlvar で 言及した問題点が適用されます。
これら全ては perl が他のプログラムに埋め込まれていて、 STDOUT や STDERR で出力する場所はなんらかの特殊なやり方でリダイレクトする 必要があるときに特に便利です。 実際の例は nvi や Apache モジュールを参照してください。
私たちの例では、叫ぶハンドルを生成します。
package Shout;これはこのクラスのコンストラクタです。 その働きはなにかの bless されたリファレンスを返すことです。 そのリファレンスは内部情報を保持するために使うことができます。
sub TIEHANDLE { print "<shout>\n"; my $i; bless \$i, shift }このメソッドは syswrite 関数を通じてハンドルが書き出されるときに 呼び出されます。
sub WRITE {
$r = shift;
my($buf,$len,$offset) = @_;
print "WRITE called, \$buf=$buf, \$len=$len, \$offset=$offset";
}このメソッドは tie されたハンドルに print 関数または say() 関数を 使って出力される度に呼び出されます。 このメソッドは自分の参照のほか、print 関数に渡すリストを受け取ります。
sub PRINT { $r = shift; $$r++; print join($,,map(uc($_),@_)),$\ }say() は print() と同様に動作しますが、$\ は \n に ローカル化されるので PRINT() の中で say() を扱うために何も特別な ことをする必要はありません。
このメソッドは tie されたハンドルに printf 関数を使って 出力される度に呼び出されます。 このメソッドは自分の参照のほか、printf 関数に渡すリストを受け取ります。
sub PRINTF {
shift;
my $fmt = shift;
print sprintf($fmt, @_);
}このメソッドはハンドルが read や sysread といった関数を通じて 読まれたときに呼び出されます。
sub READ {
my $self = shift;
my $bufref = \$_[0];
my(undef,$len,$offset) = @_;
print "READ called, \$buf=$bufref, \$len=$len, \$offset=$offset";
# add to $$bufref, set $len to number of characters read
$len;
}このメソッドは <HANDLE> を通してハンドルが読まれたときに呼び出されます。 このメソッドはもうデータがない場合には undef を返します。
sub READLINE { $r = shift; "READLINE called $$r times\n"; }このメソッドは関数 getc が呼ばれたときに呼び出されます。
sub GETC { print "Don't GETC, Get Perl"; return "a"; }このメソッドは、close 関数を通してハンドルがクローズされるときに 呼び出されます。
sub CLOSE { print "CLOSE called.\n" }その他の種類の tie と同様に、このメソッドは untie が起きたときに 呼び出されます。 これが起きたときに、「自動 CLOSE」を行うのに適切です。 後述する "The untie Gotcha" を参照してください。
他の型に対する tie と同様に、このメソッドは tie されたハンドルが 破棄されるときに呼び出されます。 これはデバッグや後始末をするのに便利です。
sub DESTROY { print "</shout>\n" }以下は私たちのサンプルをどのように使うかの例です。
tie(*FOO,'Shout');
print FOO "hello\n";
$a = 4; $b = 6;
print FOO $a, " plus ", $b, " equals ", $a + $b, "\n";
print <FOO>;全ての型に対する tie について、untie() で呼び出される UNTIE メソッドを 定義できます。 以下の "The untie Gotcha" を参照してください。
untie のコツtie() や tied() が返したオブジェクトを使おうとするならば、また、 その tie されているターゲットクラスがデストラクタを 定義しているのであれば、あなたが しなければならない 微妙なコツがあります。
セットアップとして、以下の tie の例を考えてみましょう。 これはファイルを使って、スカラに代入された値を記録し続けるというものです。
package Remember;
use strict;
use warnings;
use IO::File;
sub TIESCALAR {
my $class = shift;
my $filename = shift;
my $handle = IO::File->new( "> $filename" )
or die "Cannot open $filename: $!\n";
print $handle "The Start\n";
bless {FH => $handle, Value => 0}, $class;
}
sub FETCH {
my $self = shift;
return $self->{Value};
}
sub STORE {
my $self = shift;
my $value = shift;
my $handle = $self->{FH};
print $handle "$value\n";
$self->{Value} = $value;
}
sub DESTROY {
my $self = shift;
my $handle = $self->{FH};
print $handle "The End\n";
close $handle;
}
1;次に挙げるのは、この tie を使った例です。
use strict;
use Remember;
my $fred;
tie $fred, 'Remember', 'myfile.txt';
$fred = 1;
$fred = 4;
$fred = 5;
untie $fred;
system "cat myfile.txt";これを実行したときの出力は次のようになります。
The Start
1
4
5
The Endまずまずですね。 注意深い人は tie されたオブジェクトがここでは使われていないことを 指摘するでしょう。 そこで、Remember クラスにファイルがコメントを含むことを できるようにするメソッドを追加しましょう -- そう、このような:
sub comment {
my $self = shift;
my $text = shift;
my $handle = $self->{FH};
print $handle $text, "\n";
}次の例は、前の例を comment メソッド(tie されたオブジェクトを 必要とします)を使うために変更したものです。
use strict;
use Remember;
my ($fred, $x);
$x = tie $fred, 'Remember', 'myfile.txt';
$fred = 1;
$fred = 4;
comment $x "changing...";
$fred = 5;
untie $fred;
system "cat myfile.txt";このコードを実行したとき、なにも出力されません。 その理由はこうです。
変数が tie されたとき、それは TIESCALAR, TIEARRAY, TIEHASH といった 関数のいずれかの返した値であるオブジェクトに結び付けられます。 このオブジェクトは、通常はただ一つのリファレンス、すなわち tie され た変数からの暗黙のリファレンスだけを持っています。 untie() が呼ばれたとき、このリファレンスは破棄されます。 したがって、最初の例にあったように、オブジェクトのデストラクタ (DESTROY) が 呼び出されてオブジェクトはもはや正当なリファレンスを持たないようになり、 さらにファイルがクローズされます。
しかしながら二番目の例においては、私たちはもう一つの tie された オブジェクトへのリファレンスを $x の中に格納しました。 これは untie() されたときに、存在するオブジェクトに対する正当な リファレンスがまだ存在しているということです。 このためデストラクタはその時には呼び出されません。 そしてファイルはクローズされないのです。 何の出力も無かった理由は、ファイルバッファがディスクに フラッシュされていなかったからです。
さて、あなたはもうこれが問題であることがわかったでしょう。 では、これを避けるにはどうすればいいでしょうか? 省略可能な UNTIE メソッドが導入される前は、唯一の方法は 古き良き -w オプションだけです。 これははあなたが untie() を呼んだそのときに、(untie() の対象となっている) tie されたオブジェクトに対する正当なリファレンスがまだ存在している場合には それを指摘してくれます。 もし二番目のスクリプトを先頭の方に use warnings 'untie' を付けるか、 -w オプションをつけた状態で実行していれば、 Perl は次のような警告メッセージを出力します。
untie attempted while 1 inner references still existスクリプトを正しく動作させ、警告を黙らせるには tie されたオブジェクトが untie() を呼び出すより 前に 正当なリファレンスをなくすようにします。
undef $x;
untie $fred;今や UNTIE が存在するので、クラスデザイナーはクラス機能のどの部分が 本当に untie に関連付けられ、どの部分がオブジェクトが破壊されたときに 関連付けられるかを決定できます。 与えられたクラスについてどんな意味があるかは内部のリファレンスが 維持されているかどうかに依存しているので、tie に関係ないメソッドは オブジェクトで呼び出しできます。 しかし、ほとんどの場合、DESTROY にある機能を UNTIE メソッドに移すのが 意味のあることでしょう。
もし UNTIE メソッドが存在するなら、上記の警告は起こりません。 代わりに UNTIE メソッドは「追加の」リファレンスの数が渡され、もし適切なら 自身の警告を出力できます; 例えば、UNTIE がない場合を複製するには、 このメソッドが使えます:
sub UNTIE
{
my ($obj,$count) = @_;
carp "untie attempted while $count inner references still exist" if $count;
}興味深い幾つかの tie() の実装については DB_File や Config を 参照してください。 多くの tie() 実装のためのよい開始点は、モジュール Tie::Scalar, Tie::Array, Tie::Hash, Tie::Handle のいずれかです。
scalar(%hash) で提供されるバケツ使用情報は利用できません。 これが意味することは、真偽値コンテキストで %tied_hash を使っても正しく 動作しないということです(現在のところ、ハッシュが空かハッシュ要素かに 関わらず、このテストは常に偽となります)。
配列やハッシュのローカル化は動作しません。 スコープの終了後、配列やハッシュの値は元に戻りません。
scalar(keys(%hash)) や scalar(values(%hash)) を使ってハッシュ内の エントリの数を数えることは非効率的です; 全てのエントリに対して FIRSTKEY/NEXTKEY を使って反復する必要があるからです。
tie されたハッシュや配列のスライスは複数回の FETCH/STORE の組を引き起こします; スライス操作のための tie メソッドはありません。
(ハッシュのハッシュのような)複数レベルのデータ構造を dbm ファイルに tie することは簡単にはできません。 問題は、GDBM と Berkeley DB はサイズに制限があり、それを超えることが できないということで、また、ディスク上にあるものを参照する方法についても 問題があります。 これを解決しようとしているモジュールの一つに、DBM::Deep というものが あります。 ソースコードは perlmodlib にあるように、 あなたのお近くの CPAN サイトを確かめてください。 その名前にも関わらず、DBM::Deep は DBM を使わないことに注意してください。 問題を解決するためのもう一つの初期の試みは MLDBM で、これも CPAN から 利用可能ですが、かなり重大な制限があります。
ファイルハンドルの tie はまだ不完全です。 現在のところ、sysopen(), truncate(), flock(), fcntl(), stat(), -X は トラップできません。
Tom Christiansen
TIEHANDLE by Sven Verdoolaege <skimo@dns.ufsia.ac.be> and Doug MacEachern <dougm@osf.org>
UNTIE by Nick Ing-Simmons <nick@ing-simmons.net>
SCALAR by Tassilo von Parseval <tassilo.von.parseval@rwth-aachen.de>
Tying Arrays by Casey West <casey@geeknest.com>