File Coverage

blib/lib/Data/Transform/Reference.pm

Criterion	Covered	Total	%
statement	48	49	97.9
branch	16	18	88.8
condition	2	3	66.6
subroutine	11	11	100.0
pod	3	3	100.0
total	80	84	95.2

# vim: ts=2 sw=2 expandtab
package Data::Transform::Reference;
use strict;
use Data::Transform;

use vars qw($VERSION @ISA);
$VERSION = '0.01';
@ISA = qw(Data::Transform);

use Carp qw(croak);

sub INPUT       () { 0 }
sub BUFFER      () { 1 }
sub SERIALIZE   () { 2 }
sub DESERIALIZE () { 3 }

=pod

=head1 NAME

Data::Transform::Reference - freeze and thaw arbitrary Perl data

=head1 SYNOPSIS

  use YAML;
  use Data::Transform::Reference;

  my $filter = Data::Transform::Reference->new(
    serialize   => YAML->can('Dump');
    deserialize => YAML->can('Load');
  );

  ...
  my $string = $filter->put($some_var);

  ...
  my $other_var = $filter->get($serialized_var);

=head1 DESCRIPTION

Data::Transform::Reference allows programs to send and receive arbitrary
Perl data structures without worrying about a line protocol.  Its
put() method serializes Perl data into a byte stream suitable for
transmission.  get_one() parses the data structures back out of such a
stream.

=head1 METHODS

Data::Transform::Reference implements the standard Data::Transform API. Only
the differences are documented here.

=cut

=head2 new

new() creates and initializes a Data::Transform::Reference object. It
requires the following parameters:

=over 2

=item serializer

A code ref used to serialize data. Good candidates for this are nfreeze()
from L or Dump() from a YAML implementation.

=item deserializer

A code ref used to de-serialize data. Good candidates for this are thaw()
from L or Load() from a YAML implementation.

=back

Both code references are expected to accept a single parameter containing
the data on which to act on.

=cut

sub new {
  my $type = shift;

  croak "$type requires an even number of arguments"
    if (@_ & 1);

  my %param = @_;

  croak "$type requires a serialize parameter"
    unless defined $param{'serialize'};
  croak "$type: serialize parameter must be a CODE reference"
    unless (ref $param{'serialize'} eq 'CODE');
  croak "$type requires a deserialize parameter"
    unless defined $param{'deserialize'};
  croak "$type: deserialize parameter must be a CODE reference"
    unless (ref $param{'deserialize'} eq 'CODE');


  my $self = bless [
      [],                     # INPUT
      '',                     # BUFFER
      $param{'serialize'},    # FREEZE
      $param{'deserialize'},  # THAW
    ];

  return bless $self, $type;
}

sub clone {
  my $self = shift;

  my $new = [
      [],
      '',
      $self->[SERIALIZE],
      $self->[DESERIALIZE],
    ];

  return bless $new, ref $self;
}

sub get_pending {
   my $self = shift;
   my @ret;

   @ret = @{$self->[INPUT]};
   if (length $self->[BUFFER]) {
      unshift @ret, $self->[BUFFER];
   }

   return @ret ? \@ret : undef;
}

sub _handle_get_data {
  my ($self, $data) = @_;

  if (defined $data) {
    $self->[BUFFER] .= $data;
  }

  # Need to check lengths in octets, not characters.
  use bytes;

  if ($self->[BUFFER] =~ /^(\d+)\0/ and
      length($self->[BUFFER]) >= $1 + length($1) + 1  ) {

    substr($self->[BUFFER], 0, length($1) + 1) = "";
    my $return = substr($self->[BUFFER], 0, $1);
    substr($self->[BUFFER], 0, $1) = "";
    return $self->[DESERIALIZE]->($return);
  }

  return;
}

sub _handle_put_data {
  my ($self, $reference) = @_;

  # Need to check lengths in octets, not characters.
  use bytes;

  my $frozen = $self->[SERIALIZE]->($reference);
  return length($frozen) . "\0" . $frozen;
}

1;

__END__