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