| 1 | package sigtrap; |
| 2 | |
| 3 | =head1 NAME |
| 4 | |
| 5 | sigtrap - Perl pragma to enable simple signal handling |
| 6 | |
| 7 | =cut |
| 8 | |
| 9 | use Carp; |
| 10 | |
| 11 | $VERSION = 1.02; |
| 12 | $Verbose ||= 0; |
| 13 | |
| 14 | sub import { |
| 15 | my $pkg = shift; |
| 16 | my $handler = \&handler_traceback; |
| 17 | my $saw_sig = 0; |
| 18 | my $untrapped = 0; |
| 19 | local $_; |
| 20 | |
| 21 | Arg_loop: |
| 22 | while (@_) { |
| 23 | $_ = shift; |
| 24 | if (/^[A-Z][A-Z0-9]*$/) { |
| 25 | $saw_sig++; |
| 26 | unless ($untrapped and $SIG{$_} and $SIG{$_} ne 'DEFAULT') { |
| 27 | print "Installing handler $handler for $_\n" if $Verbose; |
| 28 | $SIG{$_} = $handler; |
| 29 | } |
| 30 | } |
| 31 | elsif ($_ eq 'normal-signals') { |
| 32 | unshift @_, grep(exists $SIG{$_}, qw(HUP INT PIPE TERM)); |
| 33 | } |
| 34 | elsif ($_ eq 'error-signals') { |
| 35 | unshift @_, grep(exists $SIG{$_}, |
| 36 | qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP)); |
| 37 | } |
| 38 | elsif ($_ eq 'old-interface-signals') { |
| 39 | unshift @_, |
| 40 | grep(exists $SIG{$_}, |
| 41 | qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP)); |
| 42 | } |
| 43 | elsif ($_ eq 'stack-trace') { |
| 44 | $handler = \&handler_traceback; |
| 45 | } |
| 46 | elsif ($_ eq 'die') { |
| 47 | $handler = \&handler_die; |
| 48 | } |
| 49 | elsif ($_ eq 'handler') { |
| 50 | @_ or croak "No argument specified after 'handler'"; |
| 51 | $handler = shift; |
| 52 | unless (ref $handler or $handler eq 'IGNORE' |
| 53 | or $handler eq 'DEFAULT') { |
| 54 | require Symbol; |
| 55 | $handler = Symbol::qualify($handler, (caller)[0]); |
| 56 | } |
| 57 | } |
| 58 | elsif ($_ eq 'untrapped') { |
| 59 | $untrapped = 1; |
| 60 | } |
| 61 | elsif ($_ eq 'any') { |
| 62 | $untrapped = 0; |
| 63 | } |
| 64 | elsif ($_ =~ /^\d/) { |
| 65 | $VERSION >= $_ or croak "sigtrap.pm version $_ required," |
| 66 | . " but this is only version $VERSION"; |
| 67 | } |
| 68 | else { |
| 69 | croak "Unrecognized argument $_"; |
| 70 | } |
| 71 | } |
| 72 | unless ($saw_sig) { |
| 73 | @_ = qw(old-interface-signals); |
| 74 | goto Arg_loop; |
| 75 | } |
| 76 | } |
| 77 | |
| 78 | sub handler_die { |
| 79 | croak "Caught a SIG$_[0]"; |
| 80 | } |
| 81 | |
| 82 | sub handler_traceback { |
| 83 | package DB; # To get subroutine args. |
| 84 | $SIG{'ABRT'} = DEFAULT; |
| 85 | kill 'ABRT', $$ if $panic++; |
| 86 | syswrite(STDERR, 'Caught a SIG', 12); |
| 87 | syswrite(STDERR, $_[0], length($_[0])); |
| 88 | syswrite(STDERR, ' at ', 4); |
| 89 | ($pack,$file,$line) = caller; |
| 90 | syswrite(STDERR, $file, length($file)); |
| 91 | syswrite(STDERR, ' line ', 6); |
| 92 | syswrite(STDERR, $line, length($line)); |
| 93 | syswrite(STDERR, "\n", 1); |
| 94 | |
| 95 | # Now go for broke. |
| 96 | for ($i = 1; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) { |
| 97 | @a = (); |
| 98 | for $arg (@args) { |
| 99 | $_ = "$arg"; |
| 100 | s/([\'\\])/\\$1/g; |
| 101 | s/([^\0]*)/'$1'/ |
| 102 | unless /^(?: -?[\d.]+ | \*[\w:]* )$/x; |
| 103 | s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; |
| 104 | s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; |
| 105 | push(@a, $_); |
| 106 | } |
| 107 | $w = $w ? '@ = ' : '$ = '; |
| 108 | $a = $h ? '(' . join(', ', @a) . ')' : ''; |
| 109 | $e =~ s/\n\s*\;\s*\Z// if $e; |
| 110 | $e =~ s/[\\\']/\\$1/g if $e; |
| 111 | if ($r) { |
| 112 | $s = "require '$e'"; |
| 113 | } elsif (defined $r) { |
| 114 | $s = "eval '$e'"; |
| 115 | } elsif ($s eq '(eval)') { |
| 116 | $s = "eval {...}"; |
| 117 | } |
| 118 | $f = "file `$f'" unless $f eq '-e'; |
| 119 | $mess = "$w$s$a called from $f line $l\n"; |
| 120 | syswrite(STDERR, $mess, length($mess)); |
| 121 | } |
| 122 | kill 'ABRT', $$; |
| 123 | } |
| 124 | |
| 125 | 1; |
| 126 | |
| 127 | __END__ |
| 128 | |
| 129 | =head1 SYNOPSIS |
| 130 | |
| 131 | use sigtrap; |
| 132 | use sigtrap qw(stack-trace old-interface-signals); # equivalent |
| 133 | use sigtrap qw(BUS SEGV PIPE ABRT); |
| 134 | use sigtrap qw(die INT QUIT); |
| 135 | use sigtrap qw(die normal-signals); |
| 136 | use sigtrap qw(die untrapped normal-signals); |
| 137 | use sigtrap qw(die untrapped normal-signals |
| 138 | stack-trace any error-signals); |
| 139 | use sigtrap 'handler' => \&my_handler, 'normal-signals'; |
| 140 | use sigtrap qw(handler my_handler normal-signals |
| 141 | stack-trace error-signals); |
| 142 | |
| 143 | =head1 DESCRIPTION |
| 144 | |
| 145 | The B<sigtrap> pragma is a simple interface to installing signal |
| 146 | handlers. You can have it install one of two handlers supplied by |
| 147 | B<sigtrap> itself (one which provides a Perl stack trace and one which |
| 148 | simply C<die()>s), or alternately you can supply your own handler for it |
| 149 | to install. It can be told only to install a handler for signals which |
| 150 | are either untrapped or ignored. It has a couple of lists of signals to |
| 151 | trap, plus you can supply your own list of signals. |
| 152 | |
| 153 | The arguments passed to the C<use> statement which invokes B<sigtrap> |
| 154 | are processed in order. When a signal name or the name of one of |
| 155 | B<sigtrap>'s signal lists is encountered a handler is immediately |
| 156 | installed, when an option is encountered it affects subsequently |
| 157 | installed handlers. |
| 158 | |
| 159 | =head1 OPTIONS |
| 160 | |
| 161 | =head2 SIGNAL HANDLERS |
| 162 | |
| 163 | These options affect which handler will be used for subsequently |
| 164 | installed signals. |
| 165 | |
| 166 | =over 4 |
| 167 | |
| 168 | =item B<stack-trace> |
| 169 | |
| 170 | The handler used for subsequently installed signals outputs a Perl stack |
| 171 | trace to STDERR and then tries to dump core. This is the default signal |
| 172 | handler. |
| 173 | |
| 174 | =item B<die> |
| 175 | |
| 176 | The handler used for subsequently installed signals calls C<die> |
| 177 | (actually C<croak>) with a message indicating which signal was caught. |
| 178 | |
| 179 | =item B<handler> I<your-handler> |
| 180 | |
| 181 | I<your-handler> will be used as the handler for subsequently installed |
| 182 | signals. I<your-handler> can be any value which is valid as an |
| 183 | assignment to an element of C<%SIG>. |
| 184 | |
| 185 | =back |
| 186 | |
| 187 | =head2 SIGNAL LISTS |
| 188 | |
| 189 | B<sigtrap> has a few built-in lists of signals to trap. They are: |
| 190 | |
| 191 | =over 4 |
| 192 | |
| 193 | =item B<normal-signals> |
| 194 | |
| 195 | These are the signals which a program might normally expect to encounter |
| 196 | and which by default cause it to terminate. They are HUP, INT, PIPE and |
| 197 | TERM. |
| 198 | |
| 199 | =item B<error-signals> |
| 200 | |
| 201 | These signals usually indicate a serious problem with the Perl |
| 202 | interpreter or with your script. They are ABRT, BUS, EMT, FPE, ILL, |
| 203 | QUIT, SEGV, SYS and TRAP. |
| 204 | |
| 205 | =item B<old-interface-signals> |
| 206 | |
| 207 | These are the signals which were trapped by default by the old |
| 208 | B<sigtrap> interface, they are ABRT, BUS, EMT, FPE, ILL, PIPE, QUIT, |
| 209 | SEGV, SYS, TERM, and TRAP. If no signals or signals lists are passed to |
| 210 | B<sigtrap>, this list is used. |
| 211 | |
| 212 | =back |
| 213 | |
| 214 | For each of these three lists, the collection of signals set to be |
| 215 | trapped is checked before trapping; if your architecture does not |
| 216 | implement a particular signal, it will not be trapped but rather |
| 217 | silently ignored. |
| 218 | |
| 219 | =head2 OTHER |
| 220 | |
| 221 | =over 4 |
| 222 | |
| 223 | =item B<untrapped> |
| 224 | |
| 225 | This token tells B<sigtrap> to install handlers only for subsequently |
| 226 | listed signals which aren't already trapped or ignored. |
| 227 | |
| 228 | =item B<any> |
| 229 | |
| 230 | This token tells B<sigtrap> to install handlers for all subsequently |
| 231 | listed signals. This is the default behavior. |
| 232 | |
| 233 | =item I<signal> |
| 234 | |
| 235 | Any argument which looks like a signal name (that is, |
| 236 | C</^[A-Z][A-Z0-9]*$/>) indicates that B<sigtrap> should install a |
| 237 | handler for that name. |
| 238 | |
| 239 | =item I<number> |
| 240 | |
| 241 | Require that at least version I<number> of B<sigtrap> is being used. |
| 242 | |
| 243 | =back |
| 244 | |
| 245 | =head1 EXAMPLES |
| 246 | |
| 247 | Provide a stack trace for the old-interface-signals: |
| 248 | |
| 249 | use sigtrap; |
| 250 | |
| 251 | Ditto: |
| 252 | |
| 253 | use sigtrap qw(stack-trace old-interface-signals); |
| 254 | |
| 255 | Provide a stack trace on the 4 listed signals only: |
| 256 | |
| 257 | use sigtrap qw(BUS SEGV PIPE ABRT); |
| 258 | |
| 259 | Die on INT or QUIT: |
| 260 | |
| 261 | use sigtrap qw(die INT QUIT); |
| 262 | |
| 263 | Die on HUP, INT, PIPE or TERM: |
| 264 | |
| 265 | use sigtrap qw(die normal-signals); |
| 266 | |
| 267 | Die on HUP, INT, PIPE or TERM, except don't change the behavior for |
| 268 | signals which are already trapped or ignored: |
| 269 | |
| 270 | use sigtrap qw(die untrapped normal-signals); |
| 271 | |
| 272 | Die on receipt one of an of the B<normal-signals> which is currently |
| 273 | B<untrapped>, provide a stack trace on receipt of B<any> of the |
| 274 | B<error-signals>: |
| 275 | |
| 276 | use sigtrap qw(die untrapped normal-signals |
| 277 | stack-trace any error-signals); |
| 278 | |
| 279 | Install my_handler() as the handler for the B<normal-signals>: |
| 280 | |
| 281 | use sigtrap 'handler', \&my_handler, 'normal-signals'; |
| 282 | |
| 283 | Install my_handler() as the handler for the normal-signals, provide a |
| 284 | Perl stack trace on receipt of one of the error-signals: |
| 285 | |
| 286 | use sigtrap qw(handler my_handler normal-signals |
| 287 | stack-trace error-signals); |
| 288 | |
| 289 | =cut |