[SCM] libmessage-passing-perl Debian packaging branch, master, updated. debian/0.111-3-14-g44f6e88

[Tomas Doran]

The following commit has been merged in the master branch:
commit f29d4c972defab04d78ac8e18456bc40f5b04a62
Author: Tomas Doran <bobtfish at bobtfish.net>
Date:   Sun Mar 4 00:28:36 2012 +0000

    Add a DSL for defining chains

diff --git a/Makefile.PL b/Makefile.PL
index 1438334..8aee4a1 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -14,6 +14,7 @@ requires 'JSON';
 requires 'JSON::XS';
 requires 'MooseX::Getopt';
 requires 'Try::Tiny';
+requires 'Task::Weaken';
 
 WriteAll;
 
diff --git a/lib/Log/Stash/DSL.pm b/lib/Log/Stash/DSL.pm
new file mode 100644
index 0000000..f7f4ad2
--- /dev/null
+++ b/lib/Log/Stash/DSL.pm
@@ -0,0 +1,96 @@
+package Log::Stash::DSL;
+
+use Moose ();
+use Moose::Exporter;
+use Log::Stash::DSL::Factory;
+use Carp qw/ confess /;
+use Scalar::Util qw/weaken/;
+use AnyEvent;
+
+Moose::Exporter->setup_import_methods(
+    as_is     => [qw/ run chain input filter output /],
+    also      => 'Moose',
+);
+
+our $FACTORY;
+sub _check_factory {
+    confess("Not inside a chain { block!!") unless $FACTORY;
+}
+
+our ($self, $class) = ('', '');
+sub chain (&) {
+    my $code = shift;
+    my ($caller, undef, undef) = caller();
+    if ($class ne $caller) {
+        $class = $caller;
+        if ($class->can('new_with_options')) {
+            $self = $class->new_with_options;
+        }
+        elsif ($class->can('new')) {
+            $self = $class->new;
+        }
+        else {
+            $self = $class;
+        }
+    }
+    if ($FACTORY) {
+        confess("Cannot chain witin a chain");
+    }
+    my $self;
+    if ($caller->can('new_with_options')) {
+        $caller->new_with_options;
+    }
+    local $FACTORY = Log::Stash::DSL::Factory->new;
+    my $ret = $self->$code();
+    my %items = $FACTORY->registry;
+    $FACTORY->clear_registry;
+    weaken($items{$_}) for keys %items;
+    foreach my $name (keys %items) {
+        next if $items{$name};
+        warn "Unused output or filter $name in chain\n";
+    }
+    return $ret;
+}
+
+sub input {
+     my ($name, %opts) = @_;
+    _check_factory();
+    $FACTORY->make(
+        %opts,
+        __name => $name,
+        __type => 'Input',
+    );
+}
+
+sub filter {
+     my ($name, %opts) = @_;
+    _check_factory();
+    $FACTORY->make(
+        %opts,
+        __name => $name,
+        __type => 'Filter',
+    );
+}
+
+sub output {
+    my ($name, %opts) = @_;
+    _check_factory();
+    $FACTORY->make(
+        %opts,
+        __name => $name,
+        __type => 'Output',
+    );
+}
+
+sub run {
+    undef $self;
+    my $chain = shift;
+    AnyEvent->condvar->recv;
+}
+
+1;
+
+=head1 NAME
+
+Log::Stash::DSL
+
diff --git a/lib/Log/Stash/DSL/Factory.pm b/lib/Log/Stash/DSL/Factory.pm
new file mode 100644
index 0000000..6a0d41b
--- /dev/null
+++ b/lib/Log/Stash/DSL/Factory.pm
@@ -0,0 +1,52 @@
+package Log::Stash::DSL::Factory;
+use Moose;
+use String::RewritePrefix;
+use namespace::autoclean;
+
+sub expand_class_name {
+    my ($self, $type, $name) = @_;
+    String::RewritePrefix->rewrite({
+        '' => 'Log::Stash::' . $type . '::',
+        '+' => ''
+    }, $name);
+}
+
+has registry => (
+    isa => 'HashRef',
+    default => sub { {} },
+    traits => ['Hash'],
+    handles => {
+        registry_get => 'get',
+        registry_has => 'get',
+        registry_set => 'set',
+        registry => 'elements',
+    },
+    lazy => 1,
+    clearer => 'clear_registry',
+);
+
+sub make {
+    my ($self, %opts) = @_;
+    my $class = delete $opts{class}
+        || confess("Class name needed");
+    my $name = delete $opts{__name};
+    my $type = delete $opts{__type};
+    confess("We already have a thing named $name")
+        if $self->registry_has($name);
+    my $output_to = $opts{output_to};
+    if ($output_to && !ref($output_to)) {
+        my $proper_output_to = $self->registry_get($output_to)
+            || confess("Do not have a component named '$output_to'");
+        $opts{output_to} = $proper_output_to;
+    }
+    $class = $self->expand_class_name($type, $class);
+    Class::MOP::load_class($class);
+    my $out = $class->new(%opts);
+    $self->registry_set($name, $out);
+    return $out;
+}
+
+__PACKAGE__->meta->make_immutable;
+1;
+
+
diff --git a/t/dsl.t b/t/dsl.t
new file mode 100644
index 0000000..884b978
--- /dev/null
+++ b/t/dsl.t
@@ -0,0 +1,30 @@
+use strict;
+use warnings;
+use Test::More;
+
+use Log::Stash::DSL;
+
+my $c = chain {
+    output test => (
+        class => 'Test',
+    );
+    filter null => (
+        class => 'Null',
+        output_to => 'test',
+    );
+    input stdin => (
+        class => 'STDIN',
+        output_to => 'null',
+    );
+};
+
+isa_ok $c, 'Log::Stash::Input::STDIN';
+isa_ok $c->output_to, 'Log::Stash::Filter::Null';
+isa_ok $c->output_to->output_to, 'Log::Stash::Output::Test';
+$c->output_to->consume({foo => 'bar'});
+my $test = $c->output_to->output_to;
+is $test->messages_count, 1;
+is_deeply [$test->messages], [{foo => 'bar'}];
+
+done_testing;
+

-- 
libmessage-passing-perl Debian packaging