File Coverage

File:blib/lib/Bit/MorseSignals/Emitter.pm
Coverage:100.0%

linestmtbrancondsubpodtimecode
1package Bit::MorseSignals::Emitter;
2
3
9
9
9
9
38
16
41
use strict;
4
9
9
9
9
51
15
50
use warnings;
5
6
9
9
9
9
54
13
73
use Carp qw/croak/;
7
9
9
9
9
59
18
75
use Encode qw/encode_utf8 is_utf8/;
8
9
9
9
9
53
15
67
use Storable qw/freeze/;
9
10
9
9
9
9
60
16
53
use Bit::MorseSignals qw/:consts/;
11
12 - 20
=head1 NAME

Bit::MorseSignals::Emitter - Base class for Bit::MorseSignals emitters.

=head1 VERSION

Version 0.06

=cut
21
22our $VERSION = '0.06';
23
24 - 40
=head1 SYNOPSIS

    use Bit::MorseSignals::Emitter;

    my $deuce = new Bit::MorseSignals::Emitter;
    $deuce->post("hlagh") for 1 .. 3;
    while (defined(my $bit = $deuce->pop)) {
     sends_by_some_mean_lets_say_signals($bit);
    }

=head1 DESCRIPTION

Base class for L<Bit::MorseSignals> emitters. Please refer to this module for more general information about the protocol.

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.

=cut
41
42sub _check_self {
43
6360
100
100
6360
71842
 croak 'First argument isn\'t a valid ' . __PACKAGE__ . ' object'
44  unless ref $_[0] and $_[0]->isa(__PACKAGE__);
45}
46
47sub _count_bits {
48
60
60
312
 my ($len, $cur, $seq, $lng) = @_[1 .. 4];
49 for (my $i = 0; $i < $len; ++$i) {
50
5346
16282
  my $bit = vec $_[0], $i, 1;
51
5346
100
18059
  if ($cur == $bit) {
52
3249
18155
   ++$seq;
53  } else {
54
2097
100
9372
   $lng->[$cur] = $seq if $seq > $lng->[$cur];
55
2097
4815
   $seq = 1;
56
2097
12320
   $cur = $bit;
57  }
58
60
143
 }
59
60
100
302
 $lng->[$cur] = $seq if $seq > $lng->[$cur];
60
60
250
 return $cur, $seq;
61}
62
63 - 69
=head1 METHODS

=head2 C<new>

L<Bit::MorseSignals::Emitter> object constructor. Currently does not take any optional argument.

=cut
70
71sub new {
72
9
9
1
170
 my $class = shift;
73
9
100
100
85
 return unless $class = ref $class || $class;
74
8
100
44
 croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
75
7
27
 my %opts = @_;
76
7
35
 my $self = {
77  queue => [],
78 };
79
7
55
 bless $self, $class;
80
7
29
 $self->reset;
81
7
29
 return $self;
82}
83
84 - 88
=head2 C<< post $msg, < type => $type > >>

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>

=cut
89
90sub post {
91
99
99
1
602
 my $self = shift;
92
99
290
 my $msg = shift;
93
99
317
 _check_self($self);
94
97
100
444
 croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
95
96
322
 my %opts = @_;
96
97
96
285
 my $type = $opts{type};
98
99
96
100
100
438
 if (defined $msg) {
100
101
54
36
36
330
115
  my @manglers = (sub { $_[0] }, \&encode_utf8, \&freeze);
102  # BM_DATA_{PLAIN, UTF8, STORABLE}
103
54
100
100
334
  $type = BM_DATA_AUTO unless defined $type and exists $manglers[$type];
104
54
100
100
280
  if (ref $msg) {
105
10
20
100
33
117
   return if { map { $_ => 1 } qw/CODE GLOB/ }->{ref $msg};
106
8
26
   $type = BM_DATA_STORABLE;
107  } elsif ($type == BM_DATA_AUTO) {
108
43
100
252
   $type = is_utf8($msg) ? BM_DATA_UTF8 : BM_DATA_PLAIN;
109  }
110
52
214
  $msg = $manglers[$type]->($msg);
111
112
52
100
361
  if ($self->{state}) { # Busy/queued, can't handle this message right now.
113
43
43
96
234
   push @{$self->{queue}}, [ $msg, $type ];
114
43
100
373
   return -1 if $self->{state} == 2; # Currently sending
115
1
1
1
2
3
6
   ($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
20
20
20
42
40
122
  ($msg, $type) = @{shift @{$self->{queue}}};
121
122 } else { # Either unused or busy sending.
123
124
22
124
  return;
125
126 }
127
128
30
112
 $self->{state} = 2;
129
130
30
74
 my $head = '';
131
30
129
 vec($head, 0, 1) = ($type & 1);
132
30
141
 vec($head, 1, 1) = ($type & 2) >> 1;
133
30
94
 vec($head, 2, 1) = 0;
134
30
78
 my $hlen = 3;
135
136
30
101
 my $len = 8 * length $msg;
137
30
108
 my @lng = (0, 0, 0);
138
30
161
 my ($cur, $seq) = _count_bits $head, $hlen, 2, 0, \@lng;
139
30
155
    ($cur, $seq) = _count_bits $msg, $len, $cur, $seq, \@lng;
140
30
100
184
    ($cur, $seq) = ($lng[0] > $lng[1]) ? (1, $lng[1])
141                                       : (0, $lng[0]); # Take the smallest.
142
30
68
 ++$seq;
143
144
30
173
 $self->{len} = 1 + $seq + $hlen + $len + $seq + 1;
145
30
98
 $self->{buf} = '';
146
30
123
 my ($i, $j, $k) = (0, 0, 0);
147
30
30
43
755
 vec($self->{buf}, $i++, 1) = $cur for 1 .. $seq;
148
30
154
 vec($self->{buf}, $i++, 1) = 1 - $cur;
149
30
30
52
533
 vec($self->{buf}, $i++, 1) = vec($head, $j++, 1) for 1 .. $hlen;
150
30
30
57
22550
 vec($self->{buf}, $i++, 1) = vec($msg, $k++, 1) for 1 .. $len;
151
30
153
 vec($self->{buf}, $i++, 1) = 1 - $cur;
152
30
30
50
724
 vec($self->{buf}, $i++, 1) = $cur for 1 .. $seq;
153
154
30
98
 $self->{pos} = 0;
155
156
30
110
 return 1;
157}
158
159 - 167
=head2 C<pop>

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 :

    while (defined(my $bit = $deuce->pop)) {
     ...
    }

=cut
168
169sub pop {
170
5768
5768
1
125728
 my ($self) = @_;
171
5768
18292
 _check_self($self);
172
5766
100
26968
 return if $self->{state} == 0;
173
5758
100
26369
 $self->post if $self->{state} == 1;
174
5758
28512
 my $bit = vec $self->{buf}, $self->{pos}++, 1;
175
5758
100
29911
 $self->reset if $self->{pos} >= $self->{len};
176
5758
42168
 return $bit;
177}
178
179 - 183
=head2 C<len>

The length of the currently posted message.

=cut
184
185sub len {
186
68
68
1
23294
 my ($self) = @_;
187
68
219
 _check_self($self);
188
66
407
 return $self->{len};
189}
190
191 - 195
=head2 C<pos>

The number of bits that have already been sent for the current message.

=cut
196
197sub pos {
198
68
68
1
247
 my ($self) = @_;
199
68
218
 _check_self($self);
200
66
348
 return $self->{pos};
201}
202
203 - 207
=head2 C<reset>

Cancels the current transfer, but does not empty the queue.

=cut
208
209sub reset {
210
39
39
1
131
 my ($self) = @_;
211
39
128
 _check_self($self);
212
37
37
73
210
 $self->{state} = @{$self->{queue}} > 0;
213
37
37
149
136
 @{$self}{qw/buf len pos/} = ();
214
37
98
 return $self;
215}
216
217 - 221
=head2 C<flush>

Flushes the queue, but does not cancel the current transfer.

=cut
222
223sub flush {
224
24
24
1
84
 my ($self) = @_;
225
24
74
 _check_self($self);
226
22
91
 $self->{queue} = [];
227
22
67
 return $self;
228}
229
230 - 234
=head2 C<busy>

True when the emitter is busy, i.e. when a packet is being chunked.

=cut
235
236sub busy {
237
259
259
1
10459
 my ($self) = @_;
238
259
832
 _check_self($self);
239
257
1866
 return $self->{state} >= 2;
240}
241
242 - 246
=head2 C<queued>

Returns the number of queued items.

=cut
247
248sub queued {
249
35
35
1
115
 my ($self) = @_;
250
35
108
 _check_self($self);
251
33
33
72
232
 return @{$self->{queue}};
252}
253
254 - 291
=head1 EXPORT

An object module shouldn't export any function, and so does this one.

=head1 DEPENDENCIES

L<Carp> (standard since perl 5), L<Encode> (since perl 5.007003), L<Storable> (idem).

=head1 SEE ALSO

L<Bit::MorseSignals>, L<Bit::MorseSignals::Receiver>.

=head1 AUTHOR

Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.

You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).

=head1 BUGS

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.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Bit::MorseSignals::Emitter

Tests code coverage report is available at L<http://www.profvince.com/perl/cover/Bit-MorseSignals>.

=head1 COPYRIGHT & LICENSE

Copyright 2008 Vincent Pit, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut
292
2931; # End of Bit::MorseSignals::Emitter