File Coverage

blib/lib/POE/Filter/Reference.pm

Criterion	Covered	Total	%
statement	94	137	68.6
branch	28	62	45.1
condition	15	34	44.1
subroutine	16	19	84.2
pod	6	6	100.0
total	159	258	61.6

# Filter::Reference partial copyright 1998 Artur Bergman
# .  Partial copyright 1999 Philip Gwyn.

package POE::Filter::Reference;

use strict;
use POE::Filter;

use vars qw($VERSION @ISA);
$VERSION = '1.370'; # NOTE - Should be #.### (three decimal places)
@ISA = qw(POE::Filter);

use Carp qw(carp croak confess);

sub BUFFER    () { 0 }
sub FREEZE    () { 1 }
sub THAW      () { 2 }
sub COMPRESS  () { 3 }
sub NO_FATALS () { 4 }
sub MAX_BUFFER () { 5 }
sub BAD_BUFFER () { 6 }
sub FIRST_UNUSED   () { 7 }

use base 'Exporter';
our @EXPORT_OK = qw( FIRST_UNUSED );

my %KNOWN_PARAMS = (
    Compression => 1,
    Serializer  => 1,
    NoFatals    => 1,
    MaxBuffer   => 1
);

#------------------------------------------------------------------------------
# Try to require one of the default freeze/thaw packages.
use vars qw( $DEF_FREEZER $DEF_FREEZE $DEF_THAW );
BEGIN {
  local $SIG{'__DIE__'} = 'DEFAULT';

  my @packages = qw(Storable FreezeThaw YAML);
  foreach my $package (@packages) {
    eval { require "$package.pm"; import $package (); };
    if ($@) {
      warn $@;
      next;
    }

    # Found a good freezer!
    $DEF_FREEZER = $package;
    last;
  }
  die "Filter::Reference requires one of @packages" unless defined $DEF_FREEZER;
}

# Some processing here
($DEF_FREEZE, $DEF_THAW) = _get_methods($DEF_FREEZER);

#------------------------------------------------------------------------------
# Try to acquire Compress::Zlib at run time.

my $zlib_status = undef;
sub _include_zlib {
  local $SIG{'__DIE__'} = 'DEFAULT';

  unless (defined $zlib_status) {
    eval "use Compress::Zlib qw(compress uncompress)";
    if ($@) {
      $zlib_status = $@;
      eval(
        "sub compress   { @_ }\n" .
        "sub uncompress { @_ }"
      );
    }
    else {
      $zlib_status = '';
    }
  }

  $zlib_status;
}

#------------------------------------------------------------------------------

sub _get_methods {
  my($freezer)=@_;
  my $freeze=$freezer->can('nfreeze') || $freezer->can('freeze');
  my $thaw=$freezer->can('thaw');
  return unless $freeze and $thaw;
  return ($freeze, $thaw);
}

#------------------------------------------------------------------------------

sub new
{
  my $type = shift;

  # Convert from old style to new style
  # $l == 1
  #     ->new( undef ) => (Serializer => undef)
  #     ->new( $class ) => (Serializer => class)
  # not defined $_[0]
  #     ->new( undef, 1 ) => (Serializer => undef, Compression => 1)
  #     ->new( undef, undef, 1 ) => (Serializer => undef, Compression => undef, NoFatals =>1)
  # $l == 3
  #     ->new( $class, 1, 1 ) => (Serializer => undef, Compression => 1, NoFatals =>1)
  # ($l <= 3 and not $KNOWN_PARAMS{$_[0]})
  #     ->new( $class, 1 )
  my %params;
  my $l = scalar @_;
  if( $l == 1 or $l == 3 or not defined $_[0] or
        ( $l<=3 and not $KNOWN_PARAMS{$_[0]}) ) {
    if( 'HASH' eq ref $_[0] ) {     # do we
        %params = %{ $_[0] };
    }
    else {
        %params = ( Serializer  => $_[0],
                    Compression => $_[1],
                    NoFatals    => $_[2]
                  );
    }
  }
  else {
    croak "$type requires an even number of parameters" if @_ and @_ & 1;
    %params = @_;
  }

  my($freeze, $thaw);
  my $freezer = $params{Serializer};
  unless (defined $freezer) {
    # Okay, load the default one!
    $freezer = $DEF_FREEZER;
    $freeze  = $DEF_FREEZE;
    $thaw    = $DEF_THAW;
  }
  else {
    # What did we get?
    if (ref $freezer) {
      # It's an object, create an closure
      my($freezetmp, $thawtmp) = _get_methods($freezer);
      $freeze = sub { $freezetmp->($freezer, @_) };
      $thaw   = sub { $thawtmp->  ($freezer, @_) };
    }
    else {
      # A package name?
      # First, find out if the package has the necessary methods.
      ($freeze, $thaw) = _get_methods($freezer);

      # If not, try to reload the module.
      unless ($freeze and $thaw) {
        my $path = $freezer;
        $path =~ s{::}{/}g;
        $path .= '.pm';

        # Force a reload if necessary.  This is naive and can leak
        # memory, so we only do it until we get the desired methods.
        delete $INC{$path};

        eval {
          local $^W = 0;
          require $path;
          $freezer->import();
        };

        carp $@ if $@;
        ($freeze, $thaw) = _get_methods($freezer);
      }
    }
  }

  # Now get the methods we want
  carp "$freezer doesn't have a freeze or nfreeze method" unless $freeze;
  carp "$freezer doesn't have a thaw method" unless $thaw;

  # Should ->new() return undef() it if fails to find the methods it
  # wants?
  return unless $freeze and $thaw;

  # Maximum buffer
  my $max_buffer = $type->__param_max( MaxBuffer => 512*1024*1024, \%params );

  # Compression
  my $compression = $params{Compression}||0;
  if ($compression) {
    my $zlib_status = _include_zlib();
    if ($zlib_status ne '') {
      warn "Compress::Zlib load failed with error: $zlib_status\n";
      carp "Filter::Reference compression option ignored";
      $compression = 0;
    }
  }

  # No fatals
  my $no_fatals = $params{NoFatals}||0;

  delete @params{ keys %KNOWN_PARAMS };
  carp("$type ignores unknown parameters: ", join(', ', sort keys %params))
    if scalar keys %params;

  my $self = bless [
    '',              # BUFFER
    $freeze,         # FREEZE
    $thaw,           # THAW
    $compression,    # COMPRESS
    $no_fatals,      # NO_FATALS
    $max_buffer,     # MAX_BUFFER
    ''               # BAD_BUFFER
  ], $type;
  $self;
}

#------------------------------------------------------------------------------

sub get {
  my ($self, $stream) = @_;
  my @return;

  $self->get_one_start($stream);
  while (1) {
    my $next = $self->get_one();
    last unless @$next;
    push @return, @$next;
  }

  return \@return;
}

#------------------------------------------------------------------------------
# 2001-07-27 RCC: The get_one() variant of get() allows Wheel::Xyz to
# retrieve one filtered block at a time.  This is necessary for filter
# changing and proper input flow control.

sub get_one_start {
  my ($self, $stream) = @_;
  $self->[BUFFER] .= join('', @$stream);
  if( $self->[MAX_BUFFER] < length( $self->[BUFFER] ) ) {
    $self->[BAD_BUFFER] = "Framing buffer exceeds the limit";
    die $self->[BAD_BUFFER] unless $self->[NO_FATALS];
  }
}

sub get_one {
  my $self = shift;

  # Need to check lengths in octets, not characters.
  BEGIN { eval { require bytes } and bytes->import; }

  if( $self->[BAD_BUFFER] ) {
    my $err = $self->[BAD_BUFFER];
    $self->[BAD_BUFFER] = '';
    return [ $err ];
  }

  if (
    $self->[BUFFER] =~ /^(\d+)\0/ and
    length($self->[BUFFER]) >= $1 + length($1) + 1
  ) {
    substr($self->[BUFFER], 0, length($1) + 1) = "";
    my $next_message = substr($self->[BUFFER], 0, $1);
    substr($self->[BUFFER], 0, $1) = "";
    $next_message = uncompress($next_message) if $self->[COMPRESS];

    unless ($self->[NO_FATALS]) {
      return [ $self->[THAW]->($next_message) ];
    }

    my $thawed = eval { $self->[THAW]->($next_message) };
    return [ "$@" ] if $@;
    return [ $thawed ];
  }

  return [ ];
}

#------------------------------------------------------------------------------
# freeze one or more references, and return a string representing them

sub put {
  my ($self, $references) = @_;

  # Need to check lengths in octets, not characters.
  BEGIN { eval { require bytes } and bytes->import; }

  my @raw = map {
    confess "Choking on a non-reference ($_)" unless ref();
    my $frozen = $self->[FREEZE]->($_);
    $frozen = compress($frozen) if $self->[COMPRESS];
    length($frozen) . "\0" . $frozen;
  } @$references;
  \@raw;
}

#------------------------------------------------------------------------------
# Return everything we have outstanding.  Do not destroy our framing
# buffer, though.

sub get_pending {
  my $self = shift;
  return undef unless length $self->[BUFFER];
  return [ $self->[BUFFER] ];
}

1;

__END__