気ままな開発室

Base::Objectクラスにプロパティを監視する機能を付加するために実装したクラスです。

Perlのtie変数の機能を利用して、変数を監視します。

package Base::Watch;

sub TIESCALAR {
	my $class  = shift;
	my $setter = shift;
	my $getter = shift;
	my $obj    = shift;

	my $self  = {
		object => $obj,
		setter => $setter,
		getter => $getter,
		value  => $value
	};

	return bless $self,$class;
}

sub FETCH {
	my $self = shift;
	my $sub  = $self->{getter};

	return $self->{value} unless $self->{object}->can($sub);

	return $self->{object}->$sub($self->{value});
}

sub STORE {
	my $self  = shift;
	my $value = shift;
	my $sub   = $self->{setter};

	if($self->{object}->can($sub)){
		$value = $self->{object}->$sub($value);
	}

	return $self->{value} = $value;
}

1;

自作のクラスに基底の動作を与えるために作成したパッケージです。

このクラスを継承して新たなクラスを作って利用します。

Perlはソースの書き方の自由度が高いため、とかく統一感の無いコーディングになりがちですが、このクラスのサブクラスを作って利用することで、ある程度の統一が取れました。

なお、コンストラクタは慣例に習ってnewです。

何をやっているか簡単に説明しますと、

１．初期化処理の管理。

２．プロパティの管理。

３．その他、こまごまとしたユーティリティなど。

くらいです。

初期化のために、initメソッドが呼ばれます。サブクラスでオーバーライドすることで、初期化処理のカスタマイズが可能。
その際は基底クラスの初期化処理を呼ぶことで初期化が保証されます。

例）

$self->SUPER::init( @_ );

プロパティを追加するにはaddPropertyメソッドを呼び出します。

例）

$self->addProperty( "width", 100);
$self->addProperty("height", 150);

プロパティの追加処理は、よほどの理由が無い限り、初期化時に呼ぶのが妥当です。

作成されたプロパティには以下のようにアクセスできます。
（実は、当初はこの表記法が使いたくてこのクラスを作りました）

例）

print $self->width;
$self->height = 200;

プロパティは、メソッドとして管理されます。
また、この表記でプロパティの代入も可能です。
これは、関数のlvalue属性（関数から左辺値を返す）を利用して実現しています。

Base::Watchクラスに依存していますが、これはsetterやgetterを実現するためのものです。
このクラスについては別途記事を書きます。

文字列化の際にtoStringメソッドが呼び出されるようにオーバーロードをおこなっています。これは他言語のマネですが、自動でおこなわれるので使いこなすと便利だったりします。たとえば、HTMLを出力するHTMLElementというクラスがあって、そのオブジェクトが$htmlだとします。

toStringメソッドでHTMLを出力するようにしてあれば

print $html;

で事足ります。

この辺りはいかにもPerlっぽい（よく言えば簡潔、悪く言えばものぐさ）気がします。

他にも若干の機能を有していますが、ここで特記するほどのものではありません。
サブクラスで利用されるときに紹介できればと思います。サブクラスを紹介する機会があれば、ですが。

ソースここから

package Base::Object;

use Base::Watch;
use overload
	'""' => toString;

sub new {
	my $class = shift;

	$class = ref $class || $class;

	my $self = bless {
		properties => {},
		propertyNames => []
	},
	$class;

	$self->init(@_);

	return $self;
}

sub init {
	my $self = shift;

	$self->{type} = 'Object';
	$self->addProperty("parentObject");
	$self->addProperty("version", "1.0");
}

sub addProperty {
	my $self = shift;
	my $name = shift || return;
	my $meth = ref($self) . "::" . $name;
	my $prop = '$_[0]->{properties}{' . $name . '}';

	$self->{properties}{$name} = shift;
	push @{$self->{propertyNames} }, $name;

	eval "sub $meth : lvalue { $prop }";
}

sub addWatchedProperty {
	my $self = shift;
	my $name = shift || return;

	$self->addProperty($name, @_);

	$self->watchProperty($name);
}

sub toString {
	my $self = shift;

	return ref $self;
}

sub getPropertyNames { $_[0]->getPropertiesName }

sub getPropertiesName {
	my $self = shift;

	return @{$self->{propertyNames}};
}

sub getMethodNames {
	my $self = shift;
	my $isa  = shift;
	my $pack = ref $self || $self;
	my @tar;
	my $m = {};

	if( $isa == 1 ) {
		push @tar, $pack;
		push @tar, @{"$pack\::ISA"};
	}

	elsif( $isa == 2 ) {
		push @tar, @{"$pack\::ISA"};
	}

	else {
		push @tar, $pack;
	}

	for my $p (@tar) {
		$p .= "::";
		for my $key ( keys %$p ){
			$m->{$key} = 1 if eval { '$p->can($key)' }
			&& $key !~ /::$|^(import|isa|ISA|BEGIN|IN|AUTOLOAD|VERSION|DESTROY|OVERLOAD)$|^\(/;
		}
	}

	return sort keys %$m;
}

sub watch {
	my $self   = shift;
	my $name   = shift;
	my $setter = shift;
	my $getter = shift;
	my $obj    = shift || $self;

	tie $obj->{$name},Base::Watch,$setter,$getter,$self;
}

sub watchProperty {
	my $self   = shift;
	my $prop   = shift || return;
	my $setter = shift || "set" . ucfirst $prop;
	my $getter = shift || "get" . ucfirst $prop;

	$self->watch($prop,$setter,$getter,$self->{properties});
}

sub isCollection {}

sub getType {
	my $self = shift;

	return $self->{type};
}

sub clone {
	my $self = shift;
	my $ret  = $self->new();

	for my $prop ( $ret->getPropertyNames ){
		$ret->$prop = $self->$prop;
	}

	return $ret;
}

1;