Serialize object role

lib/Message/Passing/Filter/Decoder/Sereal.pm

@@ -0,0 +1,74 @@
+package Message::Passing::Filter::Decoder::Sereal;
+use Moo;
+use Sereal::Decoder;
+use Try::Tiny;
+use Message::Passing::Exception::Decoding;
+use namespace::clean -except => 'meta';
+
+with qw/
+    Message::Passing::Role::Filter
+    Message::Passing::Role::HasErrorChain
+/;
+
+has sereal_args => (
+    is => 'ro',
+    default => sub { {} },
+);
+
+has _sereal => (
+    is      => 'lazy',
+    handles => [ 'decode' ],
+    default => sub {
+        my $s = shift;
+        return Sereal::Decoder->new( $s->sereal_args );
+    },
+);
+
+sub filter {
+    my ($self, $message) = @_;
+    try {
+        $self->decode( $message )
+    }
+    catch {
+        $self->error->consume(Message::Passing::Exception::Decoding->new(
+            exception => $_,
+            packed_data => $message,
+        ));
+        return; # Explicit return undef
+    };
+}
+
+1;
+
+=head1 NAME
+
+Message::Passing::Role::Filter::Decoder::Sereal
+
+=head1 DESCRIPTION
+
+Decodes string messages from Sereal into data structures.
+
+=head1 ATTRIBUTES
+
+=head1 METHODS
+
+=head2 new( %args )
+
+Constructor. On top of the generic filter arguments, accepts an optional C<sereal_args>, 
+which will be used as the arguments for the constructor of the
+underlying L<Sereal::Decoder> object.
+
+=head2 filter( $message )
+
+Sereal-decodes the message supplied as a parameter.
+
+=head1 SEE ALSO
+
+=over
+
+=item L<Message::Passing>
+
+=item L<Message::Passing::Manual::Concepts>
+
+=back
+

lib/Message/Passing/Filter/Encoder/JSON.pm

@@ -10,6 +10,7 @@ use namespace::clean -except => 'meta';
 with qw/
     Message::Passing::Role::Filter
     Message::Passing::Role::HasErrorChain
+    Message::Passing::Role::SerializeObject
 /;
 
 has pretty => (
@@ -31,14 +32,6 @@ sub filter {
     my ($self, $message) = @_;
     try {
         return $message unless ref($message);
-        if (blessed $message) { # FIXME - This should be moved out of here!
-            if ($message->can('pack')) {
-                $message = $message->pack;
-            }
-            elsif ($message->can('to_hash')) {
-                $message = $message->to_hash;
-            }
-        }
         $self->_json->encode( $message );
     }
     catch {

lib/Message/Passing/Filter/Encoder/Sereal.pm

@@ -0,0 +1,83 @@
+package Message::Passing::Filter::Encoder::Sereal;
+use Moo;
+use Sereal::Encoder;
+use Try::Tiny;
+use Message::Passing::Exception::Encoding;
+use namespace::clean -except => 'meta';
+
+with qw/
+    Message::Passing::Role::Filter
+    Message::Passing::Role::HasErrorChain
+    Message::Passing::Role::SerializeObject
+/;
+
+has sereal_args => (
+    is => 'ro',
+    default => sub { {} },
+);
+
+has _sereal => (
+    is      => 'lazy',
+    handles => [ 'encode'  ],
+    default => sub {
+        my $self = shift;
+        return Sereal::Encoder->new( $self->sereal_args );
+    },
+);
+
+sub filter {
+    my ($self, $message) = @_;
+    try {
+        $self->encode( $message );
+    }
+    catch {
+        $self->error->consume(Message::Passing::Exception::Encoding->new(
+            exception => $_,
+            stringified_data => $message,
+        ));
+        return; # Explicitly drop the message from normal processing
+    }
+}
+
+1;
+
+=head1 NAME
+
+Message::Passing::Role::Filter::Encoder::Sereal - Encodes data structures as Sereal for output
+
+=head1 DESCRIPTION
+
+This filter takes a hash ref or an object for a message, and serializes it to
+L<Sereal>.
+
+Plain refs work as expected, and classes providing either a 
+C<pack()> or C<to_hash()> method. This means that anything based on
+L<Log::Message::Structures> or L<MooseX::Storage> should be correctly
+serialized.
+
+=head1 METHODS
+
+=head2 new( %args )
+
+Constructor. On top of the generic filter arguments, accepts an optional C<sereal_args>, 
+which will be used as the arguments for the constructor of the
+underlying L<Sereal::Encoder> object.
+
+
+=head2 filter( $message )
+
+Performs the Serial encoding.
+
+
+=head1 SEE ALSO
+
+=over
+
+=item L<Message::Passing>
+
+=item L<Message::Passing::Manual::Concepts>
+
+=back
+
+=cut
+

lib/Message/Passing/Role/SerializeObject.pm

@@ -0,0 +1,39 @@
+package Message::Passing::Role::SerializeObject;
+
+use strict;
+use warnings;
+
+use Scalar::Util qw/ blessed /;
+
+use Moo::Role;
+
+around filter => sub {
+    my( $next, $self, $message ) = @_;
+
+    if (blessed $message) {
+        for ( qw/ pack to_hash / ) {
+            next unless $message->can($_);
+            $message = $message->$_;
+            last;
+        }
+    }
+
+    $self->$next( $message );
+
+};
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+Message::Passing::Role::SerializeObject - Automatically serialize objects
+
+=hea1 DESCRIPTION
+
+When used by an encoder filter, any object that implement a C<pack()> 
+or C<to_hash()> method will automatically be serialized.
+
+

t/sereal.t

@@ -0,0 +1,72 @@
+use strict;
+use warnings;
+use Test::More;
+use Try::Tiny;
+
+plan skip_all => "Sereal::Encoder or Sereal::Decoder not present"
+    unless eval <<'END';
+            use Sereal::Decoder;
+            use Sereal::Encoder;
+            1;
+END
+
+use Message::Passing::Filter::Decoder::Sereal;
+use Message::Passing::Filter::Encoder::Sereal;
+use Message::Passing::Output::Test;
+use Message::Passing::Input::Null;
+use Message::Passing::Output::Null;
+
+my $cbct = Message::Passing::Output::Test->new;
+my $cbc = Message::Passing::Input::Null->new(
+    output_to => Message::Passing::Filter::Encoder::Sereal->new(
+        output_to => Message::Passing::Filter::Decoder::Sereal->new(
+            output_to => $cbct,
+        ),
+    ),
+);
+
+# Simulate dropping a message!
+{
+    local $cbc->output_to->{output_to} = Message::Passing::Output::Null->new;
+    $cbc->output_to->consume({ foo => 'bar' });
+}
+
+is $cbct->message_count, 0;
+
+subtest structure => sub {
+    my $struct = { a => 'foo', b => [ 1,2,3] };
+    $cbc->output_to->consume( $struct );
+
+    is $cbct->message_count => 1, "message made it";
+    is_deeply( ($cbct->messages)[-1], $struct, "content is good" ); 
+};
+
+{
+    package MyObject;
+
+    use Moo;
+
+    has 'foo' => (
+        is => 'ro',
+    );
+
+    sub pack { 
+        return {
+            foo => $_[0]->foo
+        }
+    }
+
+}
+
+
+subtest object => sub {
+    my $o = MyObject->new( foo => 'bar' );
+    $cbc->output_to->consume( $o );
+
+    is $cbct->message_count => 2, "message made it";
+    is_deeply( ($cbct->messages)[-1], $o, "content is good" ); 
+};
+
+
+done_testing;
+