]> git.vpit.fr Git - perl/modules/Bit-MorseSignals.git/blob - lib/Bit/MorseSignals/Emitter.pm
POD verbatim paragraphs should fit into a terminal
[perl/modules/Bit-MorseSignals.git] / lib / Bit / 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     my $bme = Bit::MorseSignals::Emitter->new;
68
69 L<Bit::MorseSignals::Emitter> object constructor. Currently does not take any optional argument.
70
71 =cut
72
73 sub new {
74  my $class = shift;
75  return unless $class = ref $class || $class;
76  croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
77  my %opts = @_;
78  my $self = {
79   queue => [],
80  };
81  bless $self, $class;
82  $self->reset;
83  return $self;
84 }
85
86 =head2 C<post>
87
88     $bme->post($msg, type => $type);
89
90 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>
91
92 =cut
93
94 sub post {
95  my $self = shift;
96  my $msg  = shift;
97  _check_self($self);
98  croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
99  my %opts = @_;
100
101  my $type = $opts{type};
102
103  if (defined $msg) {
104
105   my @manglers = (sub { $_[0] }, \&encode_utf8, \&freeze);
106   #      BM_DATA_{PLAIN,         UTF8,          STORABLE}
107   $type = BM_DATA_AUTO unless defined $type and exists $manglers[$type];
108   if (ref $msg) {
109    return if { map { $_ => 1 } qw<CODE GLOB> }->{ref $msg};
110    $type = BM_DATA_STORABLE;
111   } elsif ($type == BM_DATA_AUTO) {
112    $type = is_utf8($msg) ? BM_DATA_UTF8 : BM_DATA_PLAIN;
113   }
114   $msg = $manglers[$type]->($msg);
115
116   if ($self->{state}) { # Busy/queued, can't handle this message right now.
117    push @{$self->{queue}}, [ $msg, $type ];
118    return -1 if $self->{state} == 2;           # Currently sending
119    ($msg, $type) = @{shift @{$self->{queue}}}; # Otherwise something's queued
120   }
121
122  } elsif ($self->{state} == 1) { # No msg was given, but the queue isn't empty.
123
124   ($msg, $type) = @{shift @{$self->{queue}}};
125
126  } else { # Either unused or busy sending.
127
128   return;
129
130  }
131
132  $self->{state} = 2;
133
134  my $head = '';
135  vec($head, 0, 1) = ($type & 1);
136  vec($head, 1, 1) = ($type & 2) >> 1;
137  vec($head, 2, 1) = 0;
138  my $hlen = 3;
139
140  my $len = 8 * length $msg;
141  my @lng = (0, 0, 0);
142  my ($cur, $seq) = _count_bits $head, $hlen, 2,    0,    \@lng;
143     ($cur, $seq) = _count_bits $msg,  $len,  $cur, $seq, \@lng;
144     ($cur, $seq) = ($lng[0] > $lng[1]) ? (1, $lng[1])
145                                        : (0, $lng[0]); # Take the smallest.
146  ++$seq;
147
148  $self->{len} = 1 + $seq + $hlen + $len + $seq + 1;
149  $self->{buf} = '';
150  my ($i, $j, $k) = (0, 0, 0);
151  vec($self->{buf}, $i++, 1) = $cur for 1 .. $seq;
152  vec($self->{buf}, $i++, 1) = 1 - $cur;
153  vec($self->{buf}, $i++, 1) = vec($head, $j++, 1) for 1 .. $hlen;
154  vec($self->{buf}, $i++, 1) = vec($msg,  $k++, 1) for 1 .. $len;
155  vec($self->{buf}, $i++, 1) = 1 - $cur;
156  vec($self->{buf}, $i++, 1) = $cur for 1 .. $seq;
157
158  $self->{pos} = 0;
159
160  return 1;
161 }
162
163 =head2 C<pop>
164
165 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 :
166
167     while (defined(my $bit = $deuce->pop)) {
168      ...
169     }
170
171 =cut
172
173 sub pop {
174  my ($self) = @_;
175  _check_self($self);
176  return      if $self->{state} == 0;
177  $self->post if $self->{state} == 1;
178  my $bit   = vec $self->{buf}, $self->{pos}++, 1;
179  $self->reset if $self->{pos} >= $self->{len};
180  return $bit;
181 }
182
183 =head2 C<len>
184
185 The length of the currently posted message.
186
187 =cut
188
189 sub len {
190  my ($self) = @_;
191  _check_self($self);
192  return $self->{len};
193 }
194
195 =head2 C<pos>
196
197 The number of bits that have already been sent for the current message.
198
199 =cut
200
201 sub pos {
202  my ($self) = @_;
203  _check_self($self);
204  return $self->{pos};
205 }
206
207 =head2 C<reset>
208
209 Cancels the current transfer, but does not empty the queue.
210
211 =cut
212
213 sub reset {
214  my ($self) = @_;
215  _check_self($self);
216  $self->{state} = @{$self->{queue}} > 0;
217  @{$self}{qw<buf len pos>} = ();
218  return $self;
219 }
220
221 =head2 C<flush>
222
223 Flushes the queue, but does not cancel the current transfer.
224
225 =cut
226
227 sub flush {
228  my ($self) = @_;
229  _check_self($self);
230  $self->{queue} = [];
231  return $self;
232 }
233
234 =head2 C<busy>
235
236 True when the emitter is busy, i.e. when a packet is being chunked.
237
238 =cut
239
240 sub busy {
241  my ($self) = @_;
242  _check_self($self);
243  return $self->{state} >= 2;
244 }
245
246 =head2 C<queued>
247
248 Returns the number of queued items.
249
250 =cut
251
252 sub queued {
253  my ($self) = @_;
254  _check_self($self);
255  return @{$self->{queue}};
256 }
257
258 =head1 EXPORT
259
260 An object module shouldn't export any function, and so does this one.
261
262 =head1 DEPENDENCIES
263
264 L<Carp> (standard since perl 5), L<Encode> (since perl 5.007003), L<Storable> (idem).
265
266 =head1 SEE ALSO
267
268 L<Bit::MorseSignals>, L<Bit::MorseSignals::Receiver>.
269
270 =head1 AUTHOR
271
272 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
273
274 You can contact me by mail or on C<irc.perl.org> (vincent).
275
276 =head1 BUGS
277
278 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.
279
280 =head1 SUPPORT
281
282 You can find documentation for this module with the perldoc command.
283
284     perldoc Bit::MorseSignals::Emitter
285
286 Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Bit-MorseSignals>.
287
288 =head1 COPYRIGHT & LICENSE
289
290 Copyright 2008 Vincent Pit, all rights reserved.
291
292 This program is free software; you can redistribute it and/or modify it
293 under the same terms as Perl itself.
294
295 =cut
296
297 1; # End of Bit::MorseSignals::Emitter