[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 3de277d6406bba4a5ecc87c30b178d47fbcc62e6
Author: Tomas Doran <bobtfish at bobtfish.net>
Date:   Sun Mar 4 16:06:41 2012 +0000

    Add filtering by key.
    
    With the T piece, this allows you to do things like send error messages
    to STDOUT and everything to ZeroMQ. This sort of thing can already be
    easily done on status with Log::Dispatch or whatever, but this module
    allows you to filter on any key at an arbitrary depth, by match or regex.

diff --git a/lib/Log/Stash/Filter/Key.pm b/lib/Log/Stash/Filter/Key.pm
new file mode 100644
index 0000000..cf21dc0
--- /dev/null
+++ b/lib/Log/Stash/Filter/Key.pm
@@ -0,0 +1,56 @@
+package Log::Stash::Filter::Key;
+use Moose;
+use Moose::Util::TypeConstraints;
+use namespace::autoclean;
+
+with 'Log::Stash::Role::Filter';
+
+has key => (
+    isa => 'Str',
+    is => 'ro',
+    required => 1,
+);
+
+has match => (
+    isa => 'Str',
+    is => 'ro',
+    required => 1,
+);
+
+has match_type => (
+    is => 'ro',
+    isa => enum(['regex', 'eq']),
+    default => 'eq',
+);
+
+has _re => (
+    is => 'ro',
+    lazy => 1,
+    default => sub {
+        my $self = shift;
+        my $match = $self->match;
+        if ($self->match_type eq 'regex') {
+            return qr/$match/;
+        }
+        else {
+            return qr/^\Q$match\E$/;
+        }
+    },
+);
+
+sub filter {
+    my ($self, $message) = @_;
+    my $re = $self->_re;
+    my @key_parts = split /\./, $self->key;
+    my $m = $message;
+    do {
+        my $part = shift(@key_parts);
+        $m = (ref($m) eq 'HASH' && exists($m->{$part})) ? $m->{$part} : undef;
+    } while ($m && scalar(@key_parts));
+    return unless $m && !ref($m) && $m =~ /$re/;
+    return $message;
+}
+
+__PACKAGE__->meta->make_immutable;
+1;
+
diff --git a/t/filter.t b/t/filter.t
index 3576420..eb0b656 100644
--- a/t/filter.t
+++ b/t/filter.t
@@ -7,6 +7,7 @@ use Log::Stash::Filter::Null;
 use Log::Stash::Output::Test;
 use Log::Stash::Filter::All;
 use Log::Stash::Filter::T;
+use Log::Stash::Filter::Key;
 
 my $called = 0;
 
@@ -74,5 +75,49 @@ is $test2->message_count, 1;
 is_deeply [$test2->messages], ['message'];
 is $called2, 1;
 
+$ob = try {
+    $test = Log::Stash::Output::Test->new(
+            on_consume_cb => sub { $called++ }
+    );
+    Log::Stash::Filter::Key->new(
+        output_to => $test,
+        key => 'foo',
+        match => 'bar',
+    );
+}
+catch { fail "Failed to construct $_" };
+ok $test;
+
+try { $ob->consume({foo => 'bar', baz => 'quux'}) }
+    catch { fail "Failed to consume message: $_" };
+try { $ob->consume({foo => 'blam', baz => 'quux'}) }
+    catch { fail "Failed to consume message: $_" };
+
+is_deeply [$test->messages], [{foo => 'bar', baz => 'quux'}];
+
+$ob = try {
+    $test = Log::Stash::Output::Test->new(
+            on_consume_cb => sub { $called++ }
+    );
+    Log::Stash::Filter::Key->new(
+        output_to => $test,
+        key => 'foo.inner.inner',
+        match => 'bar',
+    );
+}
+catch { fail "Failed to construct $_" };
+ok $test;
+
+try { $ob->consume({foo => 'bar', baz => 'quux'}) }
+    catch { fail "Failed to consume message: $_" };
+try { $ob->consume({foo => { inner => 'blam' }, baz => 'quux'}) }
+    catch { fail "Failed to consume message: $_" };
+try { $ob->consume({foo => { inner => { inner => 'blam' } }, baz => 'quux'}) }
+    catch { fail "Failed to consume message: $_" };
+try { $ob->consume({foo => { inner => { inner => 'bar' } }, baz => 'quux'}) }
+    catch { fail "Failed to consume message: $_" };
+
+is_deeply [$test->messages], [{foo => { inner => { inner => 'bar' } }, baz => 'quux'}];
+
 done_testing;
 

-- 
libmessage-passing-perl Debian packaging