| … | |
… | |
| 52 | =head2 CLASS Net::Knuddels::Protocol |
52 | =head2 CLASS Net::Knuddels::Protocol |
| 53 | |
53 | |
| 54 | You B<must> call the C<destroy> method of this class when you no longer |
54 | You B<must> call the C<destroy> method of this class when you no longer |
| 55 | use it, as circular references will keep the object alive otherwise. |
55 | use it, as circular references will keep the object alive otherwise. |
| 56 | |
56 | |
|
|
57 | =over 4 |
|
|
58 | |
|
|
59 | =item new |
|
|
60 | |
|
|
61 | Create a new C<Net::Knuddels::Protocol> object. |
|
|
62 | |
| 57 | =cut |
63 | =cut |
| 58 | |
64 | |
| 59 | sub new { |
65 | sub new { |
| 60 | my $class = shift; |
66 | my $class = shift; |
| 61 | |
67 | |
| … | |
… | |
| 71 | $self->feed_event ("connected"); |
77 | $self->feed_event ("connected"); |
| 72 | }); |
78 | }); |
| 73 | |
79 | |
| 74 | $self; |
80 | $self; |
| 75 | } |
81 | } |
|
|
82 | |
|
|
83 | =item $protocol->feed_data ($octets) |
|
|
84 | |
|
|
85 | Feed raw protocol data into the decoder. |
|
|
86 | |
|
|
87 | =cut |
| 76 | |
88 | |
| 77 | sub feed_data($$) { |
89 | sub feed_data($$) { |
| 78 | my ($self, $data) = @_; |
90 | my ($self, $data) = @_; |
| 79 | |
91 | |
| 80 | # split data stream into packets |
92 | # split data stream into packets |
| … | |
… | |
| 118 | my $bin = unpack "b*", $msg; |
130 | my $bin = unpack "b*", $msg; |
| 119 | my $res = ""; |
131 | my $res = ""; |
| 120 | |
132 | |
| 121 | while ($bin =~ /\G($RE_dec)/cmog) { |
133 | while ($bin =~ /\G($RE_dec)/cmog) { |
| 122 | my $frag = $Net::Knuddels::Dictionary->{$1}; |
134 | my $frag = $Net::Knuddels::Dictionary->{$1}; |
| 123 | $frag = pack "b*", substr $bin, 0, 16, "" if $frag eq "\\\\\\"; |
135 | $frag = pack "b*", $bin =~ /\G.{16}/cmg ? && $1 if $frag eq "\\\\\\"; |
| 124 | $res .= $frag; |
136 | $res .= $frag; |
| 125 | } |
137 | } |
| 126 | $bin =~ /\G(.*[^0].*)$/ and die "Net::Knuddels::Receiver: undecodable message tail '$1'"; |
138 | $bin =~ /\G(.*[^0].*)$/ and die "Net::Knuddels::Receiver: undecodable message tail '$1'"; |
| 127 | |
139 | |
| 128 | $self->feed_event (split /\0/, $res); |
140 | $self->feed_event (split /\0/, $res); |
| … | |
… | |
| 135 | my $ev = $self->{cb}{$_}; |
147 | my $ev = $self->{cb}{$_}; |
| 136 | $_->($type, @arg) for values %$ev; |
148 | $_->($type, @arg) for values %$ev; |
| 137 | } |
149 | } |
| 138 | } |
150 | } |
| 139 | |
151 | |
|
|
152 | =item $protocol->register ($type => $callback) |
|
|
153 | |
|
|
154 | Register a callback for events of type C<$type>, which is either the name |
|
|
155 | of a low-level event sent by the server (such as "k" for dialog box) or |
|
|
156 | the name of a generated event, such as C<connected>. |
|
|
157 | |
|
|
158 | =cut |
|
|
159 | |
| 140 | sub register { |
160 | sub register { |
| 141 | my ($self, $type, $cb) = @_; |
161 | my ($self, $type, $cb) = @_; |
| 142 | |
162 | |
| 143 | $self->{cb}{$type}{$cb} = $cb; |
163 | $self->{cb}{$type}{$cb} = $cb; |
| 144 | } |
164 | } |
| … | |
… | |
| 147 | my ($self) = @_; |
167 | my ($self) = @_; |
| 148 | |
168 | |
| 149 | delete $self->{cb}; |
169 | delete $self->{cb}; |
| 150 | } |
170 | } |
| 151 | |
171 | |
|
|
172 | =back |
|
|
173 | |
|
|
174 | =cut |
|
|
175 | |
| 152 | 1; |
176 | 1; |
| 153 | |
177 | |
