lib/Stem/Packet.pm

   1 #  File: Stem/Packet.pm
   2
   3 #  This file is part of Stem.
   4 #  Copyright (C) 1999, 2000, 2001 Stem Systems, Inc.
   5
   6 #  Stem is free software; you can redistribute it and/or modify
   7 #  it under the terms of the GNU General Public License as published by
   8 #  the Free Software Foundation; either version 2 of the License, or
   9 #  (at your option) any later version.
  10
  11 #  Stem is distributed in the hope that it will be useful,
  12 #  but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 #  GNU General Public License for more details.
  15
  16 #  You should have received a copy of the GNU General Public License
  17 #  along with Stem; if not, write to the Free Software
  18 #  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  19
  20 #  For a license to use the Stem under conditions other than those
  21 #  described here, to purchase support for this software, or to purchase a
  22 #  commercial warranty contract, please contact Stem Systems at:
  23
  24 #       Stem Systems, Inc.              781-643-7504
  25 #       79 Everett St.                  info@stemsystems.com
  26 #       Arlington, MA 02474
  27 #       USA
  28
  29 package Stem::Packet ;
  30
  31 use strict ;
  32
  33 use Stem::Class ;
  34 use Stem::Codec ;
  35
  36 my $attr_spec = [
  37
  38         {
  39                 'name'          => 'codec',
  40                 'env'           => 'packet_codec',
  41                 'default'       => 'Data::Dumper',
  42                 'help'          => <<HELP,
  43 This is the name of the Codec:: subclass that will be used in this cell
  44 HELP
  45         },
  46         {
  47                 'name'          => 'object',
  48                 'type'          => 'object',
  49                 'help'          => <<HELP,
  50 If an object is passed in, the filter will use it for callbacks
  51 HELP
  52         },
  53         {
  54                 'name'          => 'packet_method',
  55                 'default'       => 'packet_out',
  56                 'help'          => <<HELP,
  57 This method is called on the object when a packet has encoded from
  58 internal data
  59 HELP
  60         },
  61
  62         {
  63                 'name'          => 'data_method',
  64                 'default'       => 'packet_data',
  65                 'help'          => <<HELP,
  66 This method is called on the object when a packet has been decoded
  67 from external data
  68 HELP
  69         },
  70
  71 ] ;
  72
  73
  74 ###########
  75 # This POD section is autoegenerated. Any edits to it will be lost.
  76
  77 =head2 Constructor Attributes for Class Stem::Packet
  78
  79 =over 4
  80
  81
  82 =item * Attribute - B<codec>
  83
  84 =over 4
  85
  86
  87 =item Description:
  88 This is the name of the Codec:: subclass that will be used in this cell
  89
  90
  91 =item It B<defaults> to: Storable
  92 Unknown attribute env
  93
  94 =back
  95
  96 =item * Attribute - B<object>
  97
  98 =over 4
  99
 100
 101 =item Description:
 102 If an object is passed in, the filter will use it for callbacks
 103
 104
 105 =item Its B<type> is: object
 106
 107 =back
 108
 109 =item * Attribute - B<packet_method>
 110
 111 =over 4
 112
 113
 114 =item Description:
 115 This method is called on the object when a packet has encoded from
 116 internal data
 117
 118
 119 =item It B<defaults> to: packet_out
 120
 121 =back
 122
 123 =item * Attribute - B<data_method>
 124
 125 =over 4
 126
 127
 128 =item Description:
 129 This method is called on the object when a packet has been decoded
 130 from external data
 131
 132
 133 =item It B<defaults> to: packet_data
 134
 135 =back
 136
 137 =back
 138
 139 =cut
 140
 141 # End of autogenerated POD
 142 ###########
 143
 144 sub new {
 145
 146         my( $class ) = shift ;
 147
 148
 149         my $self = Stem::Class::parse_args( $attr_spec, @_ ) ;
 150         return $self unless ref $self ;
 151
 152 #       my @codec_args = exists( $self->{codec} ) ?
 153 #                       ( codec => $self->{codec} ) : () ;
 154
 155 #print "NEW PACKET CODEC $self->{codec}\n" ;
 156
 157         my $codec_obj = Stem::Codec->new( codec => $self->{codec} ) ;
 158         return $codec_obj unless ref $codec_obj ;
 159         $self->{'codec_obj'} = $codec_obj ;
 160
 161 #print "CODEC OBJ [$codec_obj]\n" ;
 162
 163         return $self ;
 164 }
 165
 166 my $END_MARK = "\012#END\012" ;
 167 my $end_mark_len = length $END_MARK ;
 168
 169
 170 sub to_packet {
 171
 172         my $self = shift ;
 173
 174         return unless @_ ;
 175 #use Data::Dumper ;
 176 #print Dumper $_[0] ;
 177
 178         my $codec_text = $self->{'codec_obj'}->encode( $_[0] ) ;
 179
 180 #print Dumper $codec_text ;
 181         my $size = length( ${$codec_text} ) ;
 182
 183 # wrap the packet text with a size/codec/end pair of lines
 184
 185         my $packet_text = "#$size:$self->{'codec'}\012${$codec_text}$END_MARK" ;
 186
 187 #print "PACKET TEXT [$packet_text]\n" ;
 188
 189         $self->_callback( 'packet_method', \$packet_text ) ;
 190         return \$packet_text ;
 191 }
 192
 193 sub to_data {
 194
 195         my( $self, $input ) = @_ ;
 196
 197 #print "IN DATA [$input]\n" ;
 198         my $buf_ref = \$self->{'buffer'} ;
 199
 200         ${$buf_ref} .= ( ref $input eq 'SCALAR' ) ? ${$input} : $input
 201                 if defined $input ;
 202
 203         my $codec = $self->{'codec'} ;
 204
 205         while( 1 ) {
 206
 207                 unless ( $self->{'packet_len'} ) {
 208
 209 # grab the packet_len if we can from the header line
 210
 211                         return unless ${$buf_ref} =~
 212                                 s/\A#(\d+):$self->{'codec'}\012// ;
 213
 214                         $self->{'packet_len'} = $1 ;
 215                 }
 216
 217                 my $packet_len = $self->{'packet_len'} || 0 ;
 218
 219 #print "PACKET_LEN [$packet_len]\n" ;
 220
 221 # see if we have a full packet with end line
 222
 223 #print "IN BUF [${$buf_ref}]\n" ;
 224
 225                 return if length( ${$buf_ref} ) < $packet_len ;
 226
 227 # old regex method was limited to 64k bytes in a packet
 228 #               return unless ${$buf_ref} =~ s/^(.{$packet_len})$END_MARK//s ;
 229
 230                 return unless
 231                 substr( ${$buf_ref}, $packet_len, $end_mark_len ) eq $END_MARK ;
 232
 233 # grab the packet data and end marker and delete it from the buffer
 234                 my $packet = substr( ${$buf_ref}, 0,
 235                                      $packet_len + $end_mark_len, '' ) ;
 236
 237 # delete the end marker from the packet
 238
 239                 substr( $packet, $packet_len, $end_mark_len, '' ) ;
 240
 241 #print "IN PACKET [$packet]\n" ;
 242
 243                 my $decoded_data = $self->{'codec_obj'}->decode( $packet ) ;
 244
 245 #use Data::Dumper ;
 246 #print "DECODED: ", Dumper( $decoded_data ) ;
 247
 248                 $self->{'packet_len'} = 0 ;
 249
 250 #local( $SIG{'__WARN__'} ) = sub {} ;
 251
 252                 next if $self->_callback( 'data_method', $decoded_data ) ;
 253                 return( $decoded_data ) ;
 254         }
 255 }
 256
 257 sub _callback {
 258
 259         my ( $self, $method_attr, @data ) = @_ ;
 260
 261         my $obj = $self->{'object'} or return ;
 262         my $method = $self->{$method_attr} ;
 263         my $code = $obj->can( $method ) or return ;
 264
 265         $obj->$code( @data ) ;
 266
 267         return 1 ;
 268 }
 269
 270 1 ;