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