home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / Block.pm < prev    next >
Encoding:
Perl POD Document  |  2004-01-22  |  8.2 KB  |  299 lines
  1. # $Id: Block.pm,v 1.14 2004/01/21 23:01:07 rcaputo Exp $
  2.  
  3. package POE::Filter::Block;
  4. use POE::Preprocessor ( isa => "POE::Macro::UseBytes" );
  5.  
  6. use strict;
  7.  
  8. use vars qw($VERSION);
  9. $VERSION = do {my@r=(q$Revision: 1.14 $=~/\d+/g);sprintf"%d."."%04d"x$#r,@r};
  10.  
  11. use Carp qw(croak);
  12.  
  13. sub BLOCK_SIZE     () { 0 }
  14. sub FRAMING_BUFFER () { 1 }
  15. sub EXPECTED_SIZE  () { 2 }
  16. sub ENCODER        () { 3 }
  17. sub DECODER        () { 4 }
  18.  
  19. #------------------------------------------------------------------------------
  20.  
  21. sub _default_decoder {
  22.   my $stuff = shift;
  23.   unless ($$stuff =~ s/^(\d+)\0//s) {
  24.     warn length($1), " strange bytes removed from stream"
  25.       if $$stuff =~ s/^(\D+)//s;
  26.     return;
  27.   }
  28.   return $1;
  29. }
  30.  
  31. sub _default_encoder {
  32.   my $stuff = shift;
  33.   substr($$stuff, 0, 0) = length($$stuff) . "\0";
  34.   return;
  35. }
  36.  
  37. sub new {
  38.   my $type = shift;
  39.   croak "$type must be given an even number of parameters" if @_ & 1;
  40.   my %params = @_;
  41.  
  42.   my ($encoder, $decoder);
  43.   my $block_size = delete $params{BlockSize};
  44.   if (defined $block_size) {
  45.     croak "$type doesn't support zero or negative block sizes"
  46.       if $block_size < 1;
  47.     croak "Can't use both LengthCodec and BlockSize at the same time"
  48.       if exists $params{LengthCodec};
  49.   }
  50.   else {
  51.     my $codec = delete $params{LengthCodec};
  52.     if ($codec) {
  53.       croak "LengthCodec must be an arrray reference"
  54.         unless ref($codec) eq "ARRAY";
  55.       croak "LengthCodec must contain two items"
  56.         unless @$codec == 2;
  57.       ($encoder, $decoder) = @$codec;
  58.       croak "LengthCodec encoder must be a code reference"
  59.         unless ref($encoder) eq "CODE";
  60.       croak "LengthCodec decoder must be a code reference"
  61.         unless ref($decoder) eq "CODE";
  62.     }
  63.     else {
  64.       $encoder = \&_default_encoder;
  65.       $decoder = \&_default_decoder;
  66.     }
  67.   }
  68.  
  69.   my $self = bless [
  70.     $block_size,  # BLOCK_SIZE
  71.     '',           # FRAMING_BUFFER
  72.     undef,        # EXPECTED_SIZE
  73.     $encoder,     # ENCODER
  74.     $decoder,     # DECODER
  75.   ], $type;
  76.  
  77.   $self;
  78. }
  79.  
  80. #------------------------------------------------------------------------------
  81.  
  82. sub get {
  83.   my ($self, $stream) = @_;
  84.   my @blocks;
  85.   $self->[FRAMING_BUFFER] .= join '', @{$stream};
  86.  
  87.   {% use_bytes %}
  88.  
  89.   # If a block size is specified, then frame input into blocks of that
  90.   # size.
  91.   if (defined $self->[BLOCK_SIZE]) {
  92.     while (length($self->[FRAMING_BUFFER]) >= $self->[BLOCK_SIZE]) {
  93.       push @blocks, substr($self->[FRAMING_BUFFER], 0, $self->[BLOCK_SIZE]);
  94.       substr($self->[FRAMING_BUFFER], 0, $self->[BLOCK_SIZE]) = '';
  95.     }
  96.   }
  97.  
  98.   # Otherwise we're doing the variable-length block thing. Look for a
  99.   # length marker, and then pull off a chunk of that length.  Repeat.
  100.  
  101.   else {
  102.     while (
  103.       defined($self->[EXPECTED_SIZE]) ||
  104.       defined(
  105.         $self->[EXPECTED_SIZE] = $self->[DECODER]->(\$self->[FRAMING_BUFFER])
  106.       )
  107.     ) {
  108.       last if (length $self->[FRAMING_BUFFER] < $self->[EXPECTED_SIZE]);
  109.  
  110.       # TODO - Four-arg substr() would be better here, but it's not
  111.       # compatible with Perl as far back as we support.
  112.       my $chunk = substr($self->[FRAMING_BUFFER], 0, $self->[EXPECTED_SIZE]);
  113.       substr($self->[FRAMING_BUFFER], 0, $self->[EXPECTED_SIZE]) = '';
  114.       $self->[EXPECTED_SIZE] = undef;
  115.  
  116.       push @blocks, $chunk;
  117.     }
  118.   }
  119.  
  120.   \@blocks;
  121. }
  122.  
  123. #------------------------------------------------------------------------------
  124. # 2001-07-27 RCC: The get_one() variant of get() allows Wheel::Xyz to
  125. # retrieve one filtered block at a time.  This is necessary for filter
  126. # changing and proper input flow control.
  127.  
  128. sub get_one_start {
  129.   my ($self, $stream) = @_;
  130.   $self->[FRAMING_BUFFER] .= join '', @$stream;
  131. }
  132.  
  133. sub get_one {
  134.   my $self = shift;
  135.  
  136.   {% use_bytes %}
  137.  
  138.   # If a block size is specified, then pull off a block of that many
  139.   # bytes.
  140.  
  141.   if (defined $self->[BLOCK_SIZE]) {
  142.     return [ ] unless length($self->[FRAMING_BUFFER]) >= $self->[BLOCK_SIZE];
  143.     my $block = substr($self->[FRAMING_BUFFER], 0, $self->[BLOCK_SIZE]);
  144.     substr($self->[FRAMING_BUFFER], 0, $self->[BLOCK_SIZE]) = '';
  145.     return [ $block ];
  146.   }
  147.  
  148.   # Otherwise we're doing the variable-length block thing.  Look for a
  149.   # length marker, and then pull off a chunk of that length.  Repeat.
  150.  
  151.   if (
  152.     defined($self->[EXPECTED_SIZE]) ||
  153.     defined(
  154.       $self->[EXPECTED_SIZE] = $self->[DECODER]->(\$self->[FRAMING_BUFFER])
  155.     )
  156.   ) {
  157.     return [ ] if length($self->[FRAMING_BUFFER]) < $self->[EXPECTED_SIZE];
  158.  
  159.     # TODO - Four-arg substr() would be better here, but it's not
  160.     # compatible with Perl as far back as we support.
  161.     my $block = substr($self->[FRAMING_BUFFER], 0, $self->[EXPECTED_SIZE]);
  162.     substr($self->[FRAMING_BUFFER], 0, $self->[EXPECTED_SIZE]) = '';
  163.     $self->[EXPECTED_SIZE] = undef;
  164.  
  165.     return [ $block ];
  166.   }
  167.  
  168.   return [ ];
  169. }
  170.  
  171. #------------------------------------------------------------------------------
  172.  
  173. sub put {
  174.   my ($self, $blocks) = @_;
  175.   my @raw;
  176.  
  177.   {% use_bytes %}
  178.  
  179.   # If a block size is specified, then just assume the put is right.
  180.   # This will cause quiet framing errors on the receiving side.  Then
  181.   # again, we'll have quiet errors if the block sizes on both ends
  182.   # differ.  Ah, well!
  183.  
  184.   if (defined $self->[BLOCK_SIZE]) {
  185.     @raw = join '', @$blocks;
  186.   }
  187.  
  188.   # No specified block size. Do the variable-length block thing. This
  189.   # steals a lot of Artur's code from the Reference filter.
  190.  
  191.   else {
  192.     @raw = @$blocks;
  193.     foreach (@raw) {
  194.       $self->[ENCODER]->(\$_);
  195.     }
  196.   }
  197.  
  198.   \@raw;
  199. }
  200.  
  201. #------------------------------------------------------------------------------
  202.  
  203. sub get_pending {
  204.   my $self = shift;
  205.   return undef unless length $self->[FRAMING_BUFFER];
  206.   [ $self->[FRAMING_BUFFER] ];
  207. }
  208.  
  209. ###############################################################################
  210. 1;
  211.  
  212. __END__
  213.  
  214. =head1 NAME
  215.  
  216. POE::Filter::Block - filter between streams and blocks
  217.  
  218. =head1 SYNOPSIS
  219.  
  220.   $filter = POE::Filter::Block->new( BlockSize => 1024 );
  221.   $filter = POE::Filter::Block->new(
  222.     LengthCodec => [ \&encoder, \&decoder ]
  223.   );
  224.   $arrayref_of_blocks =
  225.     $filter->get($arrayref_of_raw_chunks_from_driver);
  226.   $arrayref_of_streamable_chunks_for_driver =
  227.     $filter->put($arrayref_of_blocks);
  228.   $arrayref_of_leftovers =
  229.     $filter->get_pending();
  230.  
  231. =head1 DESCRIPTION
  232.  
  233. The Block filter translates data between serial streams and blocks.
  234. It can handle two kinds of block: fixed-length and length-prepended.
  235.  
  236. Fixed-length blocks are used when Block's constructor is called with a
  237. BlockSize value.  Otherwise the Block filter uses length-prepended
  238. blocks.
  239.  
  240. Users who specify block sizes less than one deserve to be soundly
  241. spanked.
  242.  
  243. In variable-length mode, a LengthCodec parameter is valid.  The
  244. LengthCodec should be a list reference of two functions: The length
  245. encoder, and the length decoder:
  246.  
  247.   LengthCodec => [ \&encoder, \&decoder ]
  248.  
  249. The encoder takes a reference to a buffer and prepends the buffer's
  250. length to it.  The default encoder prepends the ASCII representation
  251. of the buffer's length.  The length is separated from the buffer by an
  252. ASCII NUL ("\0") character.
  253.  
  254.   sub _default_encoder {
  255.     my $stuff = shift;
  256.     substr($$stuff, 0, 0) = length($$stuff) . "\0";
  257.     return;
  258.   }
  259.  
  260. Sensibly enough, the corresponding decoder removes the prepended
  261. length and separator, returning its numeric value.  It returns nothing
  262. if no length can be determined.
  263.  
  264.   sub _default_decoder {
  265.     my $stuff = shift;
  266.     unless ($$stuff =~ s/^(\d+)\0//s) {
  267.       warn length($1), " strange bytes removed from stream"
  268.         if $$stuff =~ s/^(\D+)//s;
  269.       return;
  270.     }
  271.     return $1;
  272.   }
  273.  
  274. This filter holds onto incomplete blocks until they are completed.
  275.  
  276. =head1 PUBLIC FILTER METHODS
  277.  
  278. Please see POE::Filter.
  279.  
  280. =head1 SEE ALSO
  281.  
  282. POE::Filter.
  283.  
  284. The SEE ALSO section in L<POE> contains a table of contents covering
  285. the entire POE distribution.
  286.  
  287. =head1 BUGS
  288.  
  289. The put() method doesn't verify block sizes.
  290.  
  291. =head1 AUTHORS & COPYRIGHTS
  292.  
  293. The Block filter was contributed by Dieter Pearcey, with changes by
  294. Rocco Caputo.
  295.  
  296. Please see L<POE> for more information about authors and contributors.
  297.  
  298. =cut
  299.