File Coverage

blib/lib/Net/Server/SIG.pm
Criterion Covered Total %
statement 35 40 87.5
branch 11 14 78.5
condition n/a
subroutine 6 8 75.0
pod 4 4 100.0
total 56 66 84.8


line stmt bran cond sub pod time code
1             # -*- perl -*-
2             #
3             # Net::Server::SIG - Safer signals
4             #
5             # Copyright (C) 2001-2022
6             #
7             # Paul Seamons
8             #
9             # This package may be distributed under the terms of either the
10             # GNU General Public License
11             # or the
12             # Perl Artistic License
13             #
14             # All rights reserved.
15             #
16             ################################################################
17              
18             package Net::Server::SIG;
19              
20 7     7   44 use strict;
  7         14  
  7         211  
21 7         422 use vars qw($VERSION @ISA @EXPORT_OK
22 7     7   32 %_SIG %_SIG_SUB);
  7         12  
23 7     7   39 use Exporter ();
  7         12  
  7         2182  
24              
25             $VERSION = '0.03';
26             @ISA = qw(Exporter);
27             @EXPORT_OK = qw(register_sig unregister_sig check_sigs);
28              
29             sub register_sig {
30 54 50   54 1 125 die 'Usage: register_sig( SIGNAME => \&code_ref )' if @_ % 2;
31 54 100       95 if (@_ > 2) {
32 6         75 register_sig(shift(),shift()) while @_;
33 6         26 return;
34             }
35 48         97 my $sig = shift;
36 48         133 my $code_ref = shift;
37 48         75 my $ref = ref($code_ref);
38              
39 48 100       113 if (! $ref) {
    50          
40 27 100       54 if ($code_ref eq 'DEFAULT') {
    50          
41 24         49 delete $_SIG{$sig};
42 24         99 delete $_SIG_SUB{$sig};
43 24         292 $SIG{$sig} = 'DEFAULT';
44             } elsif ($code_ref eq 'IGNORE') {
45 3         8 delete $_SIG{$sig};
46 3         5 delete $_SIG_SUB{$sig};
47 3         69 $SIG{$sig} = 'IGNORE';
48             } else {
49 0         0 die "Scalar argument limited to \"DEFAULT\" and \"IGNORE\".";
50             }
51             } elsif ($ref eq 'CODE') {
52 21         115 $_SIG{$sig} = 0;
53 21         55 $_SIG_SUB{$sig} = $code_ref;
54 21     3   411 $SIG{$sig} = sub{ $Net::Server::SIG::_SIG{$sig} = 1 };
  3         2643  
55             } else {
56 0         0 die "Unsupported sig type -- must be 'DEFAULT' or a code ref.";
57             }
58             }
59              
60 0     0 1 0 sub unregister_sig { register_sig(shift(), 'DEFAULT') }
61              
62             sub check_sigs {
63 10     10 1 66 my @found;
64 10         73 foreach my $sig (keys %_SIG){
65 60 100       247 next if ! $_SIG{$sig};
66 3         8 $_SIG{$sig} = 0;
67 3         12 push @found, $sig;
68 3         19 $_SIG_SUB{$sig}->($sig);
69             }
70 7         23 return @found;
71             }
72              
73             sub sig_is_registered {
74 0     0 1   my $sig = shift;
75 0           return $_SIG_SUB{$sig};
76             }
77              
78             1;
79              
80             =head1 NAME
81              
82             Net::Server::SIG - adpf - Safer signal handling
83              
84             =head1 SYNOPSIS
85              
86             use Net::Server::SIG qw(register_sig check_sigs);
87             use IO::Select ();
88             use POSIX qw(WNOHANG);
89              
90             my $select = IO::Select->new();
91              
92             register_sig(PIPE => 'IGNORE',
93             HUP => 'DEFAULT',
94             USR1 => sub { print "I got a SIG $_[0]\n"; },
95             USR2 => sub { print "I got a SIG $_[0]\n"; },
96             CHLD => sub { 1 while waitpid(-1, WNOHANG) > 0; },
97             );
98              
99             # add some handles to the select
100             $select->add(\*STDIN);
101              
102             # loop forever trying to stay alive
103             while (1) {
104              
105             # do a timeout to see if any signals got passed us
106             # while we were processing another signal
107             my @fh = $select->can_read(10);
108              
109             my $key;
110             my $val;
111              
112             # this is the handler for safe (fine under unsafe also)
113             if (check_sigs()) {
114             # or my @sigs = check_sigs();
115             next unless @fh;
116             }
117              
118             my $handle = $fh[@fh];
119              
120             # do something with the handle
121              
122             }
123              
124             =head1 DESCRIPTION
125              
126             Signals prior in Perl prior to 5.7 were unsafe. Since then signals
127             have been implemented in a more safe algorithm. Net::Server::SIG
128             provides backwards compatibility, while still working reliably with
129             newer releases.
130              
131             Using a property of the select() function, Net::Server::SIG attempts
132             to fix the unsafe problem. If a process is blocking on select() any
133             signal will short circuit the select. Using this concept,
134             Net::Server::SIG does the least work possible (changing one bit from 0
135             to 1). And depends upon the actual processing of the signals to take
136             place immediately after the select call via the "check_sigs"
137             function. See the example shown above and also see the sigtest.pl
138             script located in the examples directory of this distribution.
139              
140             =head1 FUNCTIONS
141              
142             =over 4
143              
144             =item C \&code_ref)>
145              
146             Takes key/value pairs where the key is the signal name, and the
147             argument is either a code ref, or the words 'DEFAULT' or 'IGNORE'.
148             The function register_sig must be used in conjunction with check_sigs,
149             and with a blocking select() function call -- otherwise, you will
150             observe the registered signal mysteriously vanish.
151              
152             =item C
153              
154             Takes the name of a signal as an argument. Calls register_sig with a
155             this signal name and 'DEFAULT' as arguments (same as
156             register_sig(SIG,'DEFAULT')
157              
158             =item C
159              
160             Checks to see if any registered signals have occurred. If so, it will
161             play the registered code ref for that signal. Return value is array
162             containing any SIGNAL names that had occurred.
163              
164             =item C
165              
166             Takes a signal name and returns any registered code_ref for that signal.
167              
168             =back
169              
170             =head1 AUTHORS
171              
172             Paul Seamons (paul@seamons.com)
173              
174             Rob B Brown (rob@roobik.com) - Provided a sounding board and feedback
175             in creating Net::Server::SIG and sigtest.pl.
176              
177             =head1 LICENSE
178              
179             This package may be distributed under the terms of either the
180             GNU General Public License
181             or the
182             Perl Artistic License
183              
184             All rights reserved.
185              
186             =cut