PerlでStateパターン

StateからContextへの参照はリークを防ぐためにScalar::Util::weakenを利用する。状態マシンだから仕方がないとはいえContext〜State間のくっつき具合は気持ち悪い。状態を追加する際にContextに手を加えずに済む実装方法はないものか。

use strict;
use warnings;

my $context = new Context();
$context->operateA();
$context->operateB();
$context->operateB();
$context->operateA();
$context->operateA();

##############################
# context class
{
	package Context;
	
	sub new{
		my $class = shift;
		my $obj = {};
		my $this = bless $obj, $class;
		
		$obj->{concreteStateA} = new ConcreteStateA($this);
		$obj->{concreteStateB} = new ConcreteStateB($this);
		$obj->{curState} = $obj->{concreteStateA};
		return $this;
	}
	
	sub setState{
		my ($this, $state) = @_;
		$this->{curState} = $state;
	}
	
	sub getConcreteStateA{
		my $this = shift;
		$this->{concreteStateA} = shift if @_;
		return $this->{concreteStateA};
	}
	
	sub getConcreteStateB{
		my $this = shift;
		$this->{concreteStateB} = shift if @_;
		return $this->{concreteStateB};
	}
	
	sub operateA{
		my ($this) = @_;
		$this->{curState}->operateA();
	}
	
	sub operateB{
		my ($this) = @_;
		$this->{curState}->operateB();
	}
}

##############################
# state class
{
	package State;
	use Scalar::Util;
	
	sub new{
		my $this = shift;
		my $context = shift;
		my $obj = {};
		$obj->{context} = $context;
		Scalar::Util::weaken($obj->{context});
		return bless $obj, $this;
	}
	
	sub operateA{
		die "need overriding\n";
	}
	
	sub operateB{
		die "need overriding\n";
	}
}

{
	package ConcreteStateA;
	use base qw(State);
	
	sub new{
		my $this = shift;
		return bless new State(@_), $this;
	}
	
	sub operateA{
		print "operateA by ConcreteStateA : stay\n";
	}
	
	sub operateB{
		my ($this) = @_;
		my $context = $this->{context};
		$context->setState($context->getConcreteStateB());
		print "operateB by ConcreteStateA : goto ConcreteStateB\n";
	}
}

{
	package ConcreteStateB;
	use base qw(State);
	
	sub new{
		my $this = shift;
		return bless new State(@_), $this;
	}
	
	sub operateA{
		my ($this) = @_;
		my $context = $this->{context};
		$context->setState($context->getConcreteStateA());
		print "operateA by ConcreteStateB : goto ConcreteStateA\n";
	}
	
	sub operateB{
		print "operateB by ConcreteStateB : stay\n";
	}
}