From: Matt S Trout <mst@shadowcat.co.uk>
Date: Mon, 20 Jan 2014 09:56:37 +0000 (+0000)
Subject: initial import
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=scpubgit%2FDKit.git;a=commitdiff_plain;h=60cda0144cd51a04c35fb2d01b55d00204aceea4

initial import
---

60cda0144cd51a04c35fb2d01b55d00204aceea4
diff --git a/lib/DX/ArrayStream.pm b/lib/DX/ArrayStream.pm
new file mode 100644
index 0000000..8c85418
--- /dev/null
+++ b/lib/DX/ArrayStream.pm
@@ -0,0 +1,18 @@
+package DX::ArrayStream;
+
+use Moo;
+
+has array => (is => 'ro', required => 1);
+
+sub from_array {
+  my ($class, @array) = @_;
+  $class->new(array => \@array);
+}
+
+sub next {
+  shift @{$_[0]->array};
+}
+
+sub is_exhausted { !@{$_[0]->array} }
+
+1;
diff --git a/lib/DX/Op/FromCode.pm b/lib/DX/Op/FromCode.pm
new file mode 100644
index 0000000..af01f76
--- /dev/null
+++ b/lib/DX/Op/FromCode.pm
@@ -0,0 +1,13 @@
+package DX::Op::FromCode;
+
+use Moo;
+
+with 'DX::Role::Op';
+
+has code => (is => 'ro', required => 1);
+
+sub run {
+  $_[0]->code->(@_);
+}
+
+1;
diff --git a/lib/DX/Role/Op.pm b/lib/DX/Role/Op.pm
new file mode 100644
index 0000000..7c70333
--- /dev/null
+++ b/lib/DX/Role/Op.pm
@@ -0,0 +1,9 @@
+package DX::Role::Op;
+
+use Moo::Role;
+
+has next => (is => 'ro');
+
+requires 'run';
+
+1;
diff --git a/lib/DX/State.pm b/lib/DX/State.pm
new file mode 100644
index 0000000..f273ddb
--- /dev/null
+++ b/lib/DX/State.pm
@@ -0,0 +1,51 @@
+package DX::State;
+
+use Moo;
+
+has next_op => (is => 'ro', required => 1);
+
+has return_stack => (is => 'ro', required => 1);
+
+has by_id => (is => 'ro', required => 1);
+
+has scope => (is => 'ro', required => 1);
+
+has last_choice => (is => 'ro', required => 1);
+
+sub scope_var {
+  my ($self, $name) = @_;
+  $self->by_id->{$self->scope->{$name}};
+}
+
+sub bind_stream_then {
+  my ($self, $var, $stream, $then) = @_;
+  warn "Binding ".$var->id." to $stream";
+  my $bound = $var->with_stream($stream);
+  $self->new(%$self,
+    by_id => { %{$self->by_id}, $var->id => $bound },
+    next_op => $then
+  )->mark_choice($bound);
+}
+
+sub mark_choice {
+  my ($self, $var) = @_;
+  $self->new(%$self,
+    last_choice => [ $self, $var ]
+  );
+}
+
+sub backtrack {
+  my ($self) = @_;
+  while (my ($state, $var) = @{$self->last_choice}) {
+    $var->bound_value; $var->clear_bound_value;
+    return $state unless $var->bound_stream->is_exhausted;
+  }
+  die "Out of options";
+}
+
+sub then {
+  my ($self, $then) = @_;
+  $self->new(%$self, next_op => $then);
+}
+
+1;
diff --git a/lib/DX/Var.pm b/lib/DX/Var.pm
new file mode 100644
index 0000000..0017ffa
--- /dev/null
+++ b/lib/DX/Var.pm
@@ -0,0 +1,18 @@
+package DX::Var;
+
+use Moo;
+
+has id => (is => 'ro', required => 1);
+
+has bound_stream => (is => 'ro');
+
+has bound_value => (is => 'lazy', clearer => 1, builder => sub {
+  $_[0]->bound_stream->next;
+});
+
+sub with_stream {
+  my ($self, $stream) = @_;
+  $self->new(%$self, bound_stream => $stream);
+}
+
+1;
diff --git a/t/basic.t b/t/basic.t
new file mode 100644
index 0000000..809c211
--- /dev/null
+++ b/t/basic.t
@@ -0,0 +1,69 @@
+use strictures 1;
+use Test::More;
+use aliased 'DX::Op::FromCode';
+use aliased 'DX::ArrayStream';
+use DX::Var;
+use DX::State;
+
+my @servers = qw(
+  kitty.scsys.co.uk
+  jim.example.com
+  joe.example.com
+  pryde.scsys.co.uk
+  bob.example.com
+);
+
+my @shells = qw(csh bash);
+
+my %shells = (
+  bash => { map +($_ => 1),
+             qw(joe.example.com kitty.scsys.co.uk pryde.scsys.co.uk) },
+  csh => { map +($_ => 1),
+             qw(jim.example.com joe.example.com bob.example.com) },
+);
+
+sub bind_array {
+  my ($var, $array) = @_;
+  sub {
+    my ($self, $state) = @_;
+    $state->bind_stream_then(
+      $state->scope_var($var),
+      ArrayStream->from_array(@$array),
+      $self->next
+    )
+  }
+}
+
+my $op = FromCode->new(
+  code => bind_array(S => \@servers),
+  next => FromCode->new(
+    code => sub {
+      my ($self, $state) = @_;
+      my $server = $state->scope_var('S')->bound_value;
+      if ($server =~ /\.example\.com$/) {
+        return $state->then($self->next);
+      }
+      return $state->backtrack;
+    },
+  )
+);
+
+my %scope = map +($_ => $_), qw(S);
+my %by_id = map +($_ => DX::Var->new(id => $_)), qw(S);
+
+my $state = DX::State->new(
+  next_op => $op,
+  return_stack => [],
+  by_id => \%by_id,
+  scope => \%scope,
+  last_choice => []
+);
+
+while (my $op = $state->next_op) {
+  $state = $op->run($state);
+  ::Dwarn($state);
+}
+
+is($state->scope_var('S')->bound_value, 'jim.example.com');
+
+done_testing;