Permalink
Browse files

Add an Observer trait. Stages are automatically observed when they ar…

…e stored in attributes with this trait. The observation role is the attribute name by default.
  • Loading branch information...
1 parent c880a14 commit 4cd6b0e8c674985031e6fe60623e720a0dfe5ef0 @rcaputo committed Aug 18, 2009
Showing with 99 additions and 1 deletion.
  1. +35 −0 docs/ObserverTrait.pm
  2. +63 −0 docs/eg-08-observer-trait.pl
  3. +1 −1 docs/requirements.otl
View
@@ -0,0 +1,35 @@
+package ObserverTrait;
+use Moose::Role;
+
+has trigger => (
+ is => 'ro',
+ default => sub {
+ sub {
+ my ($self, $value) = @_;
+
+ # TODO - Ignore the object when we're set to undef. Probably
+ # part of a clearer method. Currently we rely on the object
+ # destructing on clear, which also triggers ignore().
+
+ return unless defined $value;
+ $self->observe_role(
+ observed => $value,
+ role => $self->meta->get_attribute('child')->role(),
+ );
+ }
+ }
+);
+
+has role => (
+ isa => 'Str',
+ is => 'ro',
+ default => sub {
+ my $self = shift;
+ return $self->name();
+ },
+);
+
+package Moose::Meta::Attribute::Custom::Trait::Observer;
+sub register_implementation { 'ObserverTrait' }
+
+1;
@@ -0,0 +1,63 @@
+#!/usr/bin/perl
+
+# Demonstrate how wheels may be encapsulated in thin,
+# configuration-only subclasses.
+
+{
+ package Runner;
+ use Moose;
+ extends 'Stage';
+ use WheelRun;
+
+ use ObserverTrait;
+
+ has child => (
+ traits => ['Observer'],
+ isa => 'WheelRun|Undef',
+ is => 'rw',
+ );
+
+ sub BUILD {
+ my $self = shift;
+ $self->child(
+ WheelRun->new(
+ Program => "$^X -wle 'print qq[pid(\$\$) moo(\$_)] for 1..10; exit'",
+ )
+ );
+ }
+
+ sub on_child_stdin {
+ print "stdin flushed\n";
+ }
+
+ sub on_child_stdout {
+ my ($self, $args) = @_;
+ print "stdout: $args->{output}\n";
+ }
+
+ sub on_child_stderr {
+ my ($self, $args) = @_;
+ print "stderr: $args->{output}\n";
+ }
+
+ sub on_child_error {
+ my ($self, $args) = @_;
+ return if $args->{operation} eq "read";
+ print "$args->{operation} error $args->{errnum}: $args->{errstr}\n";
+ }
+
+ sub on_child_close {
+ my ($self, $args) = @_;
+ print "child closed all output\n";
+ }
+
+ sub on_child_signal {
+ my ($self, $args) = @_;
+ print "child $args->{pid} exited: $args->{exit}\n";
+ $self->child(undef);
+ }
+}
+
+my $runner = Runner->new();
+POE::Kernel->run();
+exit;
View
@@ -64,7 +64,7 @@
[X] 100% Containership rules are delegated to the objects themselves.
[_] 0% Runtime roles may be assigned as part of the observation, not the sub-object.
[_] 0% Multiple watchers may have the same runtime role.
- Default handler method names may be derived from roles and message types.
+ [_] 0% Default handler method names may be derived from roles and message types.
Sender is a DNS resolver.
Sender's role is "resolver".
Sender emits a "success" event.

0 comments on commit 4cd6b0e

Please sign in to comment.