77 lines
1.6 KiB
Perl
77 lines
1.6 KiB
Perl
|
|
|
|
###
|
|
### 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};
|
|
}
|