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;