PerlでObserverパターン

Subjectにremoveがないこと、ConcreteObserverのコンストラクタでSubjectオブジェクトを設定しているけど、まあいいんじゃないでしょうか。

use strict;

my $subject = new ConcreteSubject();
my @observers = ();
for(my $i = 0; $i < 5; $i++){
  my $tmp_name = "name$i";
  my $obj = new ConcreteObserver($tmp_name, $subject);
  $subject->register($obj);
}

$subject->state(2);


######################################
# subject class
{
  package Subject;
  
  sub new{
    my $this = shift;
    
    my @observer = ();
    my $obj = {
      "observer" => \@observer,
      @_
    };
    
    return bless $obj, $this;
  }
  
  sub register{
    die "need override";
  }
  
  sub notify_observer{
    die "need override";
  }
}

{
  package ConcreteSubject;
  use base qw(Subject);
  
  sub new{
    my $this = shift;
    my $obj = new Subject(state => 0, @_);
    return bless $obj, $this;
  }
  
  sub state{
    my $this = shift;
    if(@_){
      $this->{state} = shift;
      $this->notify_observer();
    }
    return $this->{state};
  }
  
  sub register{
    my $this = shift;
    my ($observer) = @_;
    push(@{$this->{observer}}, $observer);
  }
  
  sub notify_observer{
    my $this = shift;
    foreach my $obj (@{$this->{observer}}){
      $obj->update();
    }
  }
}

######################################
# observer class
{
  package Observer;
  
  sub new{
    my $this = shift;
    my $obj = {@_};
    return bless $obj, $this;
  }
  
  sub update{
    die "need override";
  }
}

{
  package ConcreteObserver;
  use base qw(Observer);
  
  sub new{
    my $this = shift;
    my $name = shift;
    my $subject = shift;
    my $obj = Observer->new("name" => $name, "subject" => $subject, @_);
    return bless $obj, $this;
  }
  
  sub name{
    my $this = shift;
    if(@_){
      $this->{name} = shift;
    }
    return $this->{name};
  }
  
  sub update{
    my $this = shift;
    my $subject = $this->{subject};
    my $state = $subject->state();
    my $name = $this->name();
    print "$name : concrete observer updated! -> $state\n";
  }
}