diff --git a/lib/Message/Passing/Filter/Decoder/Sereal.pm b/lib/Message/Passing/Filter/Decoder/Sereal.pm new file mode 100644 index 0000000..760f8f4 --- /dev/null +++ b/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, +which will be used as the arguments for the constructor of the +underlying L object. + +=head2 filter( $message ) + +Sereal-decodes the message supplied as a parameter. + +=head1 SEE ALSO + +=over + +=item L + +=item L + +=back + diff --git a/lib/Message/Passing/Filter/Encoder/JSON.pm b/lib/Message/Passing/Filter/Encoder/JSON.pm index 3245b5c..491a5c5 100644 --- a/lib/Message/Passing/Filter/Encoder/JSON.pm +++ b/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 { diff --git a/lib/Message/Passing/Filter/Encoder/Sereal.pm b/lib/Message/Passing/Filter/Encoder/Sereal.pm new file mode 100644 index 0000000..1ecdc70 --- /dev/null +++ b/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. + +Plain refs work as expected, and classes providing either a +C or C method. This means that anything based on +L or L should be correctly +serialized. + +=head1 METHODS + +=head2 new( %args ) + +Constructor. On top of the generic filter arguments, accepts an optional C, +which will be used as the arguments for the constructor of the +underlying L object. + + +=head2 filter( $message ) + +Performs the Serial encoding. + + +=head1 SEE ALSO + +=over + +=item L + +=item L + +=back + +=cut + diff --git a/lib/Message/Passing/Role/SerializeObject.pm b/lib/Message/Passing/Role/SerializeObject.pm new file mode 100644 index 0000000..84c6cb9 --- /dev/null +++ b/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 +or C method will automatically be serialized. + + diff --git a/t/sereal.t b/t/sereal.t new file mode 100644 index 0000000..f3f3bae --- /dev/null +++ b/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; +