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