Commit | Line | Data |
4536f655 |
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 ; |