File Coverage

blib/lib/IPC/MorseSignals/Emitter.pm
Criterion Covered Total %
statement 53 53 100.0
branch 15 18 83.3
condition 12 18 66.6
subroutine 12 12 100.0
pod 4 4 100.0
total 96 105 91.4


line stmt bran cond sub pod time code
1             package IPC::MorseSignals::Emitter;
2              
3 10     10   285262 use strict;
  10         23  
  10         346  
4 10     10   59 use warnings;
  10         20  
  10         308  
5              
6 10     10   56 use Carp qw/croak/;
  10         17  
  10         662  
7 10     10   5027 use POSIX qw/SIGUSR1 SIGUSR2/;
  10         38641  
  10         58  
8 10     10   15306 use Time::HiRes qw/usleep/;
  10         18120  
  10         43  
9              
10 10     10   11085 use Bit::MorseSignals::Emitter;
  10         196948  
  10         354  
11 10     10   88 use base qw/Bit::MorseSignals::Emitter/;
  10         21  
  10         5523  
12              
13             =head1 NAME
14              
15             IPC::MorseSignals::Emitter - Base class for IPC::MorseSignals emitters.
16              
17             =head1 VERSION
18              
19             Version 0.16
20              
21             =cut
22              
23             our $VERSION = '0.16';
24              
25             =head1 SYNOPSIS
26              
27             use IPC::MorseSignals::Emitter;
28              
29             my $deuce = IPC::MorseSignals::Emitter->new(speed => 1024);
30             $deuce->post('HLAGH') for 1 .. 3;
31             $deuce->send($pid);
32              
33             =head1 DESCRIPTION
34              
35             This module sends messages processed by an underlying L emitter to another process as a sequence of C (for bits 0) and C (for 1) signals.
36              
37             =cut
38              
39             sub _check_self {
40 100 100 66 100   1580 croak 'First argument isn\'t a valid ' . __PACKAGE__ . ' object'
41             unless ref $_[0] and $_[0]->isa(__PACKAGE__);
42             }
43              
44             =head1 METHODS
45              
46             =head2 C<< new < delay => $seconds, speed => $bauds, %bme_options > >>
47              
48             Creates a new emitter object. C specifies the delay between two sends, in seconds, while C is the number of bits sent per second. The delay value has priority over the speed. Default delay is 1 second. Extra arguments are passed to L.
49              
50             =cut
51              
52             sub new {
53 14     14 1 7653 my $class = shift;
54 14   50     116 $class = ref $class || $class || return;
55 14 50       69 croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
56 14         42 my %opts = @_;
57             # delay supersedes speed
58 14         35 my $delay = delete $opts{delay}; # fractional seconds
59 14 100       48 if (!defined $delay) {
60 10   100     55 my $speed = delete $opts{speed} || 0; # bauds
61 10         19 $speed = int $speed;
62 10 100       40 $delay = abs(1 / $speed) if $speed;
63             }
64 14         129 my $self = $class->SUPER::new(%opts);
65 14   100     568 $self->{delay} = abs($delay || 1 + 0.0);
66 14         67 bless $self, $class;
67             }
68              
69             =head2 C
70              
71             Sends messages enqueued with L 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).
72              
73             =cut
74              
75             sub send {
76 43     43 1 5531 my ($self, $dest) = @_;
77 43         371 _check_self($self);
78 43 100       188 return unless defined $dest;
79 42         89 my %count;
80 42 50 33     1135 my @dests = grep $_ > 0 && !$count{$_}++, # Remove duplicates.
81             ref $dest eq 'ARRAY' ? map int, grep defined, @$dest
82             : int $dest;
83 42 50       654 return unless @dests;
84 42         267 while (defined(my $bit = $self->pop)) {
85 10391         595527 my @sigs = (SIGUSR1, SIGUSR2);
86 10391         38384 my $d = $self->{delay} * 1_000_000;
87 10391         22381132 $d -= usleep $d while $d > 0;
88 10391         697441 kill $sigs[$bit] => @dests;
89             }
90             }
91              
92             =head2 C<< delay < $seconds > >>
93              
94             Returns the current delay in seconds, or set it if an argument is provided.
95              
96             =cut
97              
98             sub delay {
99 10     10 1 1151 my ($self, $delay) = @_;
100 10         21 _check_self($self);
101 10 100 66     29 $self->{delay} = abs $delay if $delay and $delay += 0.0;
102 10         43 return $self->{delay};
103             }
104              
105             =head2 C<< speed < $bauds > >>
106              
107             Returns the current speed in bauds, or set it if an argument is provided.
108              
109             =cut
110              
111             sub speed {
112 47     47 1 2044713 my ($self, $speed) = @_;
113 47         522 _check_self($self);
114 46 100 66     591 $self->{delay} = 1 / (abs $speed) if $speed and $speed = int $speed;
115 46         254 return int(1 / $self->{delay});
116             }
117              
118             =pod
119              
120             IPC::MorseSignals::Emitter objects also inherit methods from L.
121              
122             =head1 EXPORT
123              
124             An object module shouldn't export any function, and so does this one.
125              
126             =head1 DEPENDENCIES
127              
128             L.
129              
130             L (standard since perl 5), L (idem) and L (since perl 5.7.3) are required.
131              
132             =head1 SEE ALSO
133              
134             L, L.
135              
136             L, L, L.
137              
138             L for information about signals in perl.
139              
140             For truly useful IPC, search for shared memory, pipes and semaphores.
141              
142             =head1 AUTHOR
143              
144             Vincent Pit, C<< >>, L.
145              
146             You can contact me by mail or on C (vincent).
147              
148             =head1 BUGS
149              
150             Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
151              
152             =head1 SUPPORT
153              
154             You can find documentation for this module with the perldoc command.
155              
156             perldoc IPC::MorseSignals::Emitter
157              
158             =head1 COPYRIGHT & LICENSE
159              
160             Copyright 2007,2008,2013 Vincent Pit, all rights reserved.
161              
162             This program is free software; you can redistribute it and/or modify it
163             under the same terms as Perl itself.
164              
165             =cut
166              
167             1; # End of IPC::MorseSignals::Emitter