first commit

perl/Examples/Chap9/Wire.pm

@@ -0,0 +1,76 @@
+
+
+###
+### Wire.pm
+###
+
+## Chapter 9 section 2.1
+
+package Wire;
+
+my $N = 0;
+sub new {
+  my ($class, $name) = @_;
+  $name ||= "wire" . ++$N;
+  bless { N => $name, S => undef, V => undef, A => [] } => $class;
+}
+sub make {
+  my $class = shift;
+  my $N = shift;
+  my @wires;
+  push @wires, $class->new while $N--;
+  @wires;
+}
+sub set {
+  my ($self, $settor, $value) = @_;
+  if (! $self->has_settor || $self->settor_is($settor)) {
+    $self->{V} = $value;
+    $self->{S} = $settor;
+    $self->notify_all_but($settor, $value);
+  } elsif ($self->has_settor) {
+    unless ($value == $self->value) {
+      my $v = $self->value;
+      my $N = $self->name;
+      warn "Wire $N inconsistent value ($value != $v)\n";
+    }
+  }
+}
+sub notify_all_but {
+  my ($self, $exception, $value) = @_;
+  for my $node ($self->attachments) {
+    next if $node == $exception;
+    $node->notify;
+  }
+}
+sub attach {
+  my ($self, @nodes) = @_;
+  push @{$self->{A}}, @nodes;
+}
+
+sub attachments { @{$_[0]->{A}} }
+sub name {
+  $_[0]{N} || "$_[0]";
+}
+
+sub settor { $_[0]{S} }
+sub has_settor { defined $_[0]{S} }
+sub settor_is { $_[0]{S} == $_[1] }
+sub revoke {
+  my ($self, $revoker) = @_;
+  return unless $self->has_value;
+  return unless $self->settor_is($revoker);
+  undef $self->{V};
+  $self->notify_all_but($revoker, undef);
+  undef $self->{S};
+}
+
+1;
+sub value { my ($self, $querent) = @_;
+            return if $self->settor_is($querent);
+            $self->{V};
+          }
+
+sub has_value { my ($self, $querent) = @_;
+                return if $self->settor_is($querent);
+                defined $_[0]{V};
+              }