1: #
2: # First of a three part post of modules that implement
3: # an extension of Perl's built-in alarm functionality.
4: #
5: # See [Alarm::Queued] and [Alarm::Concurrent]
6: # for the other two parts.
7: #
8: # Props to [tye] for explaining what I needed to know
9: # to get this to work.
10: #
11: package Alarm::_TieSIG;
12:
13: =head1 NAME
14:
15: Alarm::_TieSIG - Module handling tying of %SIG for alarm extensions.
16:
17: =head1 DESCRIPTION
18:
19: This is an internal utility module for use with the Alarm::*
20: alarm extensions, that handles tying of the Perl built-in
21: variable C<%SIG>. This is deep magic and you use this module
22: at your own risk.
23:
24: To use this class, simply C<use> it and then call the
25: C<Alarm::_TieSIG::tiesig()> function. This replaces C<%SIG> with a dummy tied hash.
26:
27: Whenever the new C<%SIG> is accessed, this class checks to see
28: if the requested key is ALRM. If so, it calls C<sethandler()>
29: for STORE's, and C<gethandler()> for FETCHes. You must provide
30: both of these methods in your package.
31:
32: All other operations are passed on to the original, magic C<%SIG>.
33:
34: Note: Do I<not> call C<tiesig()> more than once. Doing so
35: produces a warning and no other effects.
36:
37: =head1 EXAMPLE
38:
39: The following code will disable, with warnings, attempts to
40: set SIGALRM handlers in your program (although it's not
41: impossible to get past if someone really wanted to):
42:
43: use Alarm::_TieSIG;
44: Alarm::_TieSIG::tiesig();
45:
46: sub sethandler {
47: warn "\$SIG{ALRM} has been disabled.\n";
48: }
49:
50: sub gethandler {
51: warn "\$SIG{ALRM} has been disabled.\n";
52: }
53:
54: =head1 DISCLAIMER
55:
56: This module is not guaranteed to work. In fact, it will probably
57: break at the most inconvient time. If this module breaks your
58: program, destroys your computer, ruins your life, or otherwise
59: makes you unhappy, do I<not> complain (especially not to me).
60: It's your own fault.
61:
62: =head1 AUTHOR
63:
64: Written by Cory Johns (c) 2001.
65:
66: =cut
67:
68: use strict;
69: use Carp;
70:
71: use vars qw($realSig);
72:
73: sub tiesig {
74: if($realSig) {
75: carp "Attempt to re-tie %SIG";
76: return;
77: }
78:
79: $realSig = \%SIG; # Save old %SIG.
80: *SIG = {}; # Replace %SIG with a dummy.
81:
82: my $userPkg = caller;
83: return tie %SIG, __PACKAGE__, $userPkg, @_;
84: }
85:
86: sub _setAlrm {
87: $realSig->{ALRM} = shift;
88: }
89:
90: sub TIEHASH {
91: return bless {'userPkg'=>$_[1]}, shift;
92: }
93:
94: sub STORE {
95: my ($self, $key, $value) = @_;
96:
97: if($key eq 'ALRM') {
98: no strict 'refs';
99: &{"$self->{userPkg}::sethandler"}($value);
100: } else {
101: $realSig->{$key} = $value;
102: }
103: }
104:
105: sub FETCH {
106: my ($self, $key) = @_;
107:
108: if($key eq 'ALRM') {
109: no strict 'refs';
110: &{"$self->{userPkg}::gethandler"}();
111: } else {
112: return $realSig->{$key};
113: }
114: }
115:
116: sub EXISTS {
117: return exists $realSig->{$_[1]};
118: }
119:
120: sub DELETE {
121: return delete $realSig->{$_[1]};
122: }
123:
124: sub CLEAR {
125: return %$realSig = ();
126: }
127:
128: sub FIRSTKEY {
129: return each %$realSig;
130: }
131:
132: sub NEXTKEY {
133: return each %$realSig;
134: }
135:
136: sub DESTROY {
137: }
138:
139: 1;