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