]> git.vpit.fr Git - perl/modules/Bit-MorseSignals.git/blob - MorseSignals/Emitter.pm
Update VPIT::TestHelpers to 15e8aee3
[perl/modules/Bit-MorseSignals.git] / MorseSignals / Emitter.pm
1 package Bit::MorseSignals::Emitter;
2
3 use strict;
4 use warnings;
5
6 use Carp     qw<croak>;
7 use Encode   qw<encode_utf8 is_utf8>;
8 use Storable qw<freeze>;
9
10 use Bit::MorseSignals qw<:consts>;
11
12 =head1 NAME
13
14 Bit::MorseSignals::Emitter - Base class for Bit::MorseSignals emitters.
15
16 =head1 VERSION
17
18 Version 0.08
19
20 =cut
21
22 our $VERSION = '0.08';
23
24 =head1 SYNOPSIS
25
26     use Bit::MorseSignals::Emitter;
27
28     my $deuce = Bit::MorseSignals::Emitter->new;
29     $deuce->post("hlagh") for 1 .. 3;
30     while (defined(my $bit = $deuce->pop)) {
31      sends_by_some_mean_lets_say_signals($bit);
32     }
33
34 =head1 DESCRIPTION
35
36 Base class for L<Bit::MorseSignals> emitters. Please refer to this module for more general information about the protocol.
37
38 The emitter object enqueues messages and prepares them one by one into L<Bit::MorseSignals> packets. It gives then back the bits of the packet in the order they should be sent.
39
40 =cut
41
42 sub _check_self {
43  croak 'First argument isn\'t a valid ' . __PACKAGE__ . ' object'
44   unless ref $_[0] and $_[0]->isa(__PACKAGE__);
45 }
46
47 sub _count_bits {
48  my ($len, $cur, $seq, $lng) = @_[1 .. 4];
49  for (my $i = 0; $i < $len; ++$i) {
50   my $bit = vec $_[0], $i, 1;
51   if ($cur == $bit) {
52    ++$seq;
53   } else {
54    $lng->[$cur] = $seq if $seq > $lng->[$cur];
55    $seq = 1;
56    $cur = $bit;
57   }
58  }
59  $lng->[$cur] = $seq if $seq > $lng->[$cur];
60  return $cur, $seq;
61 }
62
63 =head1 METHODS
64
65 =head2 C<new>
66
67 L<Bit::MorseSignals::Emitter> object constructor. Currently does not take any optional argument.
68
69 =cut
70
71 sub new {
72  my $class = shift;
73  return unless $class = ref $class || $class;
74  croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
75  my %opts = @_;
76  my $self = {
77   queue => [],
78  };
79  bless $self, $class;
80  $self->reset;
81  return $self;
82 }
83
84 =head2 C<< post $msg, < type => $type > >>
85
86 Adds C<$msg> to the message queue and, if no other message is currently processed, dequeue the oldest item and prepare it. The type is automatically chosen, but you may want to try to force it with the C<type> option : C<$type> is then one of the C<BM_DATA_*> constants listed in L<Bit::MorseSignals/CONSTANTS>
87
88 =cut
89
90 sub post {
91  my $self = shift;
92  my $msg  = shift;
93  _check_self($self);
94  croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
95  my %opts = @_;
96
97  my $type = $opts{type};
98
99  if (defined $msg) {
100
101   my @manglers = (sub { $_[0] }, \&encode_utf8, \&freeze);
102   #      BM_DATA_{PLAIN,         UTF8,          STORABLE}
103   $type = BM_DATA_AUTO unless defined $type and exists $manglers[$type];
104   if (ref $msg) {
105    return if { map { $_ => 1 } qw<CODE GLOB> }->{ref $msg};
106    $type = BM_DATA_STORABLE;
107   } elsif ($type == BM_DATA_AUTO) {
108    $type = is_utf8($msg) ? BM_DATA_UTF8 : BM_DATA_PLAIN;
109   }
110   $msg = $manglers[$type]->($msg);
111
112   if ($self->{state}) { # Busy/queued, can't handle this message right now.
113    push @{$self->{queue}}, [ $msg, $type ];
114    return -1 if $self->{state} == 2;           # Currently sending
115    ($msg, $type) = @{shift @{$self->{queue}}}; # Otherwise something's queued
116   }
117
118  } elsif ($self->{state} == 1) { # No msg was given, but the queue isn't empty.
119
120   ($msg, $type) = @{shift @{$self->{queue}}};
121
122  } else { # Either unused or busy sending.
123
124   return;
125
126  }
127
128  $self->{state} = 2;
129
130  my $head = '';
131  vec($head, 0, 1) = ($type & 1);
132  vec($head, 1, 1) = ($type & 2) >> 1;
133  vec($head, 2, 1) = 0;
134  my $hlen = 3;
135
136  my $len = 8 * length $msg;
137  my @lng = (0, 0, 0);
138  my ($cur, $seq) = _count_bits $head, $hlen, 2,    0,    \@lng;
139     ($cur, $seq) = _count_bits $msg,  $len,  $cur, $seq, \@lng;
140     ($cur, $seq) = ($lng[0] > $lng[1]) ? (1, $lng[1])
141                                        : (0, $lng[0]); # Take the smallest.
142  ++$seq;
143
144  $self->{len} = 1 + $seq + $hlen + $len + $seq + 1;
145  $self->{buf} = '';
146  my ($i, $j, $k) = (0, 0, 0);
147  vec($self->{buf}, $i++, 1) = $cur for 1 .. $seq;
148  vec($self->{buf}, $i++, 1) = 1 - $cur;
149  vec($self->{buf}, $i++, 1) = vec($head, $j++, 1) for 1 .. $hlen;
150  vec($self->{buf}, $i++, 1) = vec($msg,  $k++, 1) for 1 .. $len;
151  vec($self->{buf}, $i++, 1) = 1 - $cur;
152  vec($self->{buf}, $i++, 1) = $cur for 1 .. $seq;
153
154  $self->{pos} = 0;
155
156  return 1;
157 }
158
159 =head2 C<pop>
160
161 If a message is being processed, pops the next bit in the packet. When the message is over, the next in the queue is immediatly prepared and the first bit of the new packet is given back. If the queue is empty, C<undef> is returned. You may want to use this method with the idiom :
162
163     while (defined(my $bit = $deuce->pop)) {
164      ...
165     }
166
167 =cut
168
169 sub pop {
170  my ($self) = @_;
171  _check_self($self);
172  return      if $self->{state} == 0;
173  $self->post if $self->{state} == 1;
174  my $bit   = vec $self->{buf}, $self->{pos}++, 1;
175  $self->reset if $self->{pos} >= $self->{len};
176  return $bit;
177 }
178
179 =head2 C<len>
180
181 The length of the currently posted message.
182
183 =cut
184
185 sub len {
186  my ($self) = @_;
187  _check_self($self);
188  return $self->{len};
189 }
190
191 =head2 C<pos>
192
193 The number of bits that have already been sent for the current message.
194
195 =cut
196
197 sub pos {
198  my ($self) = @_;
199  _check_self($self);
200  return $self->{pos};
201 }
202
203 =head2 C<reset>
204
205 Cancels the current transfer, but does not empty the queue.
206
207 =cut
208
209 sub reset {
210  my ($self) = @_;
211  _check_self($self);
212  $self->{state} = @{$self->{queue}} > 0;
213  @{$self}{qw<buf len pos>} = ();
214  return $self;
215 }
216
217 =head2 C<flush>
218
219 Flushes the queue, but does not cancel the current transfer.
220
221 =cut
222
223 sub flush {
224  my ($self) = @_;
225  _check_self($self);
226  $self->{queue} = [];
227  return $self;
228 }
229
230 =head2 C<busy>
231
232 True when the emitter is busy, i.e. when a packet is being chunked.
233
234 =cut
235
236 sub busy {
237  my ($self) = @_;
238  _check_self($self);
239  return $self->{state} >= 2;
240 }
241
242 =head2 C<queued>
243
244 Returns the number of queued items.
245
246 =cut
247
248 sub queued {
249  my ($self) = @_;
250  _check_self($self);
251  return @{$self->{queue}};
252 }
253
254 =head1 EXPORT
255
256 An object module shouldn't export any function, and so does this one.
257
258 =head1 DEPENDENCIES
259
260 L<Carp> (standard since perl 5), L<Encode> (since perl 5.007003), L<Storable> (idem).
261
262 =head1 SEE ALSO
263
264 L<Bit::MorseSignals>, L<Bit::MorseSignals::Receiver>.
265
266 =head1 AUTHOR
267
268 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
269
270 You can contact me by mail or on C<irc.perl.org> (vincent).
271
272 =head1 BUGS
273
274 Please report any bugs or feature requests to C<bug-bit-morsesignals-emitter at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Bit-MorseSignals>.  I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
275
276 =head1 SUPPORT
277
278 You can find documentation for this module with the perldoc command.
279
280     perldoc Bit::MorseSignals::Emitter
281
282 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Bit-MorseSignals>.
283
284 =head1 COPYRIGHT & LICENSE
285
286 Copyright 2008 Vincent Pit, all rights reserved.
287
288 This program is free software; you can redistribute it and/or modify it
289 under the same terms as Perl itself.
290
291 =cut
292
293 1; # End of Bit::MorseSignals::Emitter