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.01
  19
  20 =cut
  21
  22 our $VERSION = '0.01';
  23
  24 =head1 SYNOPSIS
  25
  26     use Bit::MorseSignals;
  27
  28     my $deuce = new Bit::MorseSignals::Emitter;
  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::MorseSignal::Emitter> object constructor. Currently does not take any optional argument.
  68
  69 =cut
  70
  71 sub new {
  72  my $class = shift;
  73  $class = ref $class || $class || return;
  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 & 2) >> 1;
 132  vec($head, 1, 1) = ($type & 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<reset>
 180
 181 Cancels the current transfer, but does not empty the queue.
 182
 183 =cut
 184
 185 sub reset {
 186  my ($self) = @_;
 187  _check_self($self);
 188  $self->{state} = @{$self->{queue}} > 0;
 189  @{$self}{qw/buf len pos/} = ();
 190  return $self;
 191 }
 192
 193 =head2 C<flush>
 194
 195 Flushes the queue, but does not cancel the current transfer.
 196
 197 =cut
 198
 199 sub flush {
 200  my ($self) = @_;
 201  _check_self($self);
 202  $self->{queue} = [];
 203  return $self;
 204 }
 205
 206 =head2 C<busy>
 207
 208 True when the emitter is busy, i.e. when a packet is being chunked.
 209
 210 =cut
 211
 212 sub busy {
 213  my ($self) = @_;
 214  _check_self($self);
 215  return $self->{state} >= 2;
 216 }
 217
 218 =head2 C<queued>
 219
 220 Returns the number of queued items.
 221
 222 =cut
 223
 224 sub queued {
 225  my ($self) = @_;
 226  _check_self($self);
 227  return @{$self->{queue}};
 228 }
 229
 230 =head1 EXPORT
 231
 232 An object module shouldn't export any function, and so does this one.
 233
 234 =head1 DEPENDENCIES
 235
 236 L<Carp> (standard since perl 5), L<Encode> (since perl 5.007003), L<Storable> (idem).
 237
 238 =head1 SEE ALSO
 239
 240 L<Bit::MorseSignals>, L<Bit::MorseSignals::Receiver>.
 241
 242 =head1 AUTHOR
 243
 244 Vincent Pit, C<< <perl at profvince.com> >>
 245
 246 You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
 247
 248 =head1 BUGS
 249
 250 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.
 251
 252 =head1 SUPPORT
 253
 254 You can find documentation for this module with the perldoc command.
 255
 256     perldoc Bit::MorseSignals::Emitter
 257
 258 =head1 COPYRIGHT & LICENSE
 259
 260 Copyright 2008 Vincent Pit, all rights reserved.
 261
 262 This program is free software; you can redistribute it and/or modify it
 263 under the same terms as Perl itself.
 264
 265 =cut
 266
 267 1; # End of Bit::MorseSignals::Emitter