動的な継承クラス生成

Perl

ちょっと脳みそをPerlモードにして集中しなきゃならんので、ウォーミングアップなどを。
必要に応じてクラスを動的に生成できるかどうか、実施で試してみた。文字コードは全てutf8Nで。

Object.pm

package Object;
use strict;
use utf8;
use HTML::Template;
our $t = HTML::Template->new(
	filename=>'class.tmpl'
);
use base qw ( Class::Accessor );
__PACKAGE__->mk_accessors(qw(
	dummy
));
sub is {
	my $self = shift;
	return $_[0] eq __PACKAGE__ ? 1 : ();
}
our %class_list = ();
sub make_child_class {
	# 子クラスを作る。作った子クラスの名前を返す。
	# 引数には、子クラスの名前を入れる。
	# 元になったクラスのクラス名＋'::'.与えた子クラス名のクラスを作る。
	my $self = shift;
	my $child_name = shift;
	$child_name eq '' and return (); # 子クラス名は必ず与えようね。
	my $class = ref $self;
	$class ||= $self;
	my $child_class = $class.'::'.$child_name;

	unless ( $class_list{$child_class} ) {
		$t->param(class_name=>$child_class);
		$t->param(parent=>$class);
		$t->param(name=>$child_name);
		
		$class_list{$child_class} = $t->output;
		eval $class_list{$child_class};
	}
	return $child_class;
}
1;

class.tmpl

{
	package <!--TMPL_VAR name="class_name"-->;
	use base qw ( <!--TMPL_VAR name="parent"--> );
	sub is {
		my $self = shift;
		my $test = shift;
		$test ||= 'Object';
		$test eq '<!--TMPL_VAR name="name"-->' and return 1;
		return $self->SUPER::is($test);
	}
}

main.pl

use strict;
use utf8;
use Data::Dumper;
use Object;
my $ob1 = Object->new;
my $child_class = Object->make_child_class('Item');
my $ob2 = $child_class->new;
print Data::Dumper->new([$ob1, $ob2], [qw( ob1 ob2 )])->Dump();
print $ob2->is('Item');

結論

できるっぽい。
たとえば、

  • Object
  • Object::Item
  • Object::Item::Equipment
  • Object::Item::Equipment::Weapon
  • Object::Item::Equipment::Weapon::Sword
  • Object::Item::Equipment::Weapon::Sword::Broadsword

なんて継承関係のある親子クラスを、必要な時に必要なだけ作れると言うことだ。
まあ、そゆことだわな。