add perl version state pattern

README.md

@@ -23,7 +23,7 @@ composite | [DONE](./src/composite/composite.md) | [DONE](./src/composite/cpp) |
 interpreter | [DONE](./src/interpreter/interpreter.md) | [DONE](./src/interpreter/cpp) | [DONE](./src/interpreter/java) | [TODO] | [DONE](./src/interpreter/php)
 mediator | [DONE](./src/mediator/mediator.md) | [DONE](./src/mediator/cpp) | [DONE](./src/mediator/java) | [DONE](./src/mediator/python) | [DONE](./src/mediator/php) | [DONE](./src/mediator/perl)
 memento	| [DONE](./src/memento/memento.md) | [DONE](./src/memento/cpp) | [DONE](./src/memento/java) | [DONE](./src/memento/python) | [DONE](./src/memento/php)
-state |	[DONE](./src/state/state.md) | [DONE](./src/state/cpp) | [DONE](./src/state/java) | [DONE](./src/state/python) | [DONE](./src/state/php)
+state |	[DONE](./src/state/state.md) | [DONE](./src/state/cpp) | [DONE](./src/state/java) | [DONE](./src/state/python) | [DONE](./src/state/php) | [DONE](./src/state/perl)
 prototype | [DONE](./src/prototype/prototype.md) | [DONE](./src/prototype/cpp) | [DONE](./src/prototype/java) | [DONE](./src/prototype/python) | [DONE](./src/prototype/php)
 strategy | [DONE](./src/strategy/strategy.md) | [DONE](./src/strategy/cpp) | [DONE](./src/strategy/java) | [DONE](./src/strategy/python) | [DONE](./src/strategy/php)
 visitor | [DONE](./src/visitor/visitor.md) | [DONE](./src/visitor/cpp) | [DONE](./src/visitor/java) | [DONE](./src/visitor/python) | [DONE](./src/visitor/php) | [DONE](./src/visitor/perl)

src/state/perl/Context.pm

@@ -0,0 +1,26 @@
+package Context;
+
+use strict;
+use warnings;
+use State::ConcreteStateA;
+
+sub new {
+	my ($class, $args) = @_;
+	my $self = {
+		state	=> State::ConcreteStateA->new,
+	};
+	return bless $self, $class;
+}
+
+sub state {
+	my ($self, $state) = @_;
+	$self->{state} = $state if defined($state);
+	return $self->{state};
+}
+
+sub request {
+	my ($self) = @_;
+	$self->state->handle($self);
+}
+
+1;

src/state/perl/State.pm

@@ -0,0 +1,23 @@
+package State;
+
+use strict;
+use warnings;
+
+my $instance = undef;
+
+sub new {
+	my ($class, $args) = @_;
+	my $self = {};
+	return bless $self, $class;
+}
+
+sub instance {
+	$instance = State->new if not defined($instance);
+	return $instance;
+}
+
+sub handle {
+	die "INTERFACE METHOD HANDLE CANNOT BE CALLED DIRECTLY\n";
+}
+
+1;

src/state/perl/State/ConcreteStateA.pm

@@ -0,0 +1,21 @@
+package State::ConcreteStateA;
+use parent State;
+
+use strict;
+use warnings;
+use State::ConcreteStateB;
+use Data::Dump;
+
+sub new {
+	my ($class, $args) = @_;
+	my $self = $class->SUPER::new($args);
+	return $self;
+}
+
+sub handle {
+	my ($self, $context) = @_;
+	print "ConcreteStateA handle method\n";
+	$context->state(State::ConcreteStateB->new);
+}
+
+1;

src/state/perl/State/ConcreteStateB.pm

@@ -0,0 +1,21 @@
+package State::ConcreteStateB;
+use parent State;
+
+use strict;
+use warnings;
+use State::ConcreteStateA;
+use Data::Dump;
+
+sub new {
+	my ($class, $args) = @_;
+	my $self = $class->SUPER::new($args);
+	return $self;
+}
+
+sub handle {
+	my ($self, $context) = @_;
+	print "ConcreteStateB handle method\n";
+	$context->state(State::ConcreteStateA->new);
+}
+
+1;

src/state/perl/test.pl

@@ -0,0 +1,13 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use State::ConcreteStateA;
+use State::ConcreteStateB;
+use Context;
+
+my $context = Context->new;
+$context->request;
+$context->request;
+$context->request;
+$context = undef;