Emitter.pm

   1 package IPC::MorseSignals::Emitter;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp        qw<croak>;
   7 use POSIX       qw<SIGUSR1 SIGUSR2>;
   8 use Time::HiRes qw<usleep>;
   9
  10 use Bit::MorseSignals::Emitter;
  11 use base qw<Bit::MorseSignals::Emitter>;
  12
  13 =head1 NAME
  14
  15 IPC::MorseSignals::Emitter - Base class for IPC::MorseSignals emitters.
  16
  17 =head1 VERSION
  18
  19 Version 0.17
  20
  21 =cut
  22
  23 our $VERSION = '0.17';
  24
  25 =head1 WARNING
  26
  27 Due to the POSIX signals specification (which I wasn't aware of at the time I wrote this module), this module is by nature completely unreliable and will never work properly.
  28 It is therefore B<deprecated>.
  29 Please don't use it (if you were actually crazy enough to use it).
  30
  31 =head1 SYNOPSIS
  32
  33     use IPC::MorseSignals::Emitter;
  34
  35     my $deuce = IPC::MorseSignals::Emitter->new(speed => 1024);
  36     $deuce->post('HLAGH') for 1 .. 3;
  37     $deuce->send($pid);
  38
  39 =head1 DESCRIPTION
  40
  41 This module sends messages processed by an underlying L<Bit::MorseSignal> emitter to another process as a sequence of C<SIGUSR1> (for bits 0) and C<SIGUSR2> (for 1) signals.
  42
  43 =cut
  44
  45 sub _check_self {
  46  croak 'First argument isn\'t a valid ' . __PACKAGE__ . ' object'
  47   unless ref $_[0] and $_[0]->isa(__PACKAGE__);
  48 }
  49
  50 =head1 METHODS
  51
  52 =head2 C<new>
  53
  54     my $ime = IPC::MorseSignals::Emitter->new(
  55      delay => $seconds,
  56      speed => $bauds,
  57      %bme_options,
  58     );
  59
  60 Creates a new emitter object.
  61 C<delay> specifies the delay between two sends, in seconds, while C<speed> is the number of bits sent per second.
  62 The delay value has priority over the speed, and defaults to 1 second.
  63 Extra arguments are passed to L<Bit::MorseSignals::Emitter/new>.
  64
  65 =cut
  66
  67 sub new {
  68  my $class = shift;
  69  $class = ref $class || $class || return;
  70  croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
  71  my %opts = @_;
  72  # delay supersedes speed
  73  my $delay = delete $opts{delay};       # fractional seconds
  74  if (!defined $delay) {
  75   my $speed = delete $opts{speed} || 0; # bauds
  76   $speed = int $speed;
  77   $delay = abs(1 / $speed) if $speed;
  78  }
  79  my $self = $class->SUPER::new(%opts);
  80  $self->{delay} = abs($delay || 1 + 0.0);
  81  bless $self, $class;
  82 }
  83
  84 =head2 C<send>
  85
  86     $ime->send($pid);
  87
  88 Sends messages enqueued with L<Bit::MorseSignals::Emitter/post> to the process C<$pid> (or to all the C<@$pid> if C<$pid> is an array reference, in which case duplicated targets are stripped off).
  89
  90 =cut
  91
  92 sub send {
  93  my ($self, $dest) = @_;
  94  _check_self($self);
  95  return unless defined $dest;
  96  my %count;
  97  my @dests = grep $_ > 0 && !$count{$_}++, # Remove duplicates.
  98               ref $dest eq 'ARRAY' ? map int, grep defined, @$dest
  99                                    : int $dest;
 100  return unless @dests;
 101  while (defined(my $bit = $self->pop)) {
 102   my @sigs = (SIGUSR1, SIGUSR2);
 103   my $d = $self->{delay} * 1_000_000;
 104   $d -= usleep $d while $d > 0;
 105   kill $sigs[$bit] => @dests;
 106  }
 107 }
 108
 109 =head2 C<delay>
 110
 111     my $delay = $ime->delay;
 112     $ime->delay($seconds);
 113
 114 Returns the current delay in seconds, or set it if an argument is provided.
 115
 116 =cut
 117
 118 sub delay {
 119  my ($self, $delay) = @_;
 120  _check_self($self);
 121  $self->{delay} = abs $delay if $delay and $delay += 0.0;
 122  return $self->{delay};
 123 }
 124
 125 =head2 C<speed>
 126
 127     my $speed = $ime->speed;
 128     $ime->speed($bauds);
 129
 130 Returns the current speed in bauds, or set it if an argument is provided.
 131
 132 =cut
 133
 134 sub speed {
 135  my ($self, $speed) = @_;
 136  _check_self($self);
 137  $self->{delay} = 1 / (abs $speed) if $speed and $speed = int $speed;
 138  return int(1 / $self->{delay});
 139 }
 140
 141 =pod
 142
 143 IPC::MorseSignals::Emitter objects also inherit methods from L<Bit::MorseSignals::Emitter>.
 144
 145 =head1 EXPORT
 146
 147 An object module shouldn't export any function, and so does this one.
 148
 149 =head1 DEPENDENCIES
 150
 151 L<Bit::MorseSignals::Emitter>.
 152
 153 L<Carp> (standard since perl 5), L<POSIX> (idem) and L<Time::HiRes> (since perl 5.7.3) are required.
 154
 155 =head1 SEE ALSO
 156
 157 L<IPC::MorseSignals>, L<IPC::MorseSignals::Receiver>.
 158
 159 L<Bit::MorseSignals>, L<Bit::MorseSignals::Emitter>, L<Bit::MorseSignals::Receiver>.
 160
 161 L<perlipc> for information about signals in perl.
 162
 163 For truly useful IPC, search for shared memory, pipes and semaphores.
 164
 165 =head1 AUTHOR
 166
 167 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 168
 169 You can contact me by mail or on C<irc.perl.org> (vincent).
 170
 171 =head1 BUGS
 172
 173 Please report any bugs or feature requests to C<bug-ipc-morsesignals-emitter at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=IPC-MorseSignals>.
 174 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 175
 176 =head1 SUPPORT
 177
 178 You can find documentation for this module with the perldoc command.
 179
 180     perldoc IPC::MorseSignals::Emitter
 181
 182 =head1 COPYRIGHT & LICENSE
 183
 184 Copyright 2007,2008,2013,2017 Vincent Pit, all rights reserved.
 185
 186 This program is free software; you can redistribute it and/or modify it
 187 under the same terms as Perl itself.
 188
 189 =cut
 190
 191 1; # End of IPC::MorseSignals::Emitter