Path: utzoo!utgpu!news-server.csri.toronto.edu!rutgers!tut.cis.ohio-state.edu!pacific.mps.ohio-state.edu!zaphod.mps.ohio-state.edu!uakari.primate.wisc.edu!aplcen!haven!uvaarpa!mmdf
From: telxon!ping!gorpong@uunet.uu.net
Newsgroups: comp.lang.perl
Subject: Re: How to do alarm()?
Message-ID: <1990Oct31.041758.15623@uvaarpa.Virginia.EDU>
Date: 31 Oct 90 04:17:58 GMT
Sender: mmdf@uvaarpa.Virginia.EDU (Uvaarpa Mail System)
Reply-To: telxon!ping!gorpong@uunet.uu.net
Organization: The Internet
Lines: 362

<> From: clipper@chan.csd.uwo.ca (Khun Yee Fung)
<> 
<> I have tried to do Perl's equivalence of alarm() on and off for two
<> months now. I still don't know a good solution. I tried using
<> syscall() but did not know how to get result back. I tried putting
<> alarm() in perl myself but it did not work. Can somebody tell me how I
<> can do alarm() or equivalent in Perl? Thank you very much. I don't
<> want to use the usub feature.

<> From: lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall)
<> 
<> By popular demand, I'm adding alarm() to Perl in the next patch.  After all,
<> the code (what there is of it) is already linked in order to support sleep().

Until that point, here is my package I hacked up.  The good part of this
is it tests for the existence of a REAL alarm() function in perl, and if
it exists, it will always call that function.  If it does not exist, then
it will emulate the alarm function.  That means if you place this file in
your perl-lib directory and require "alarm.pl"; everytime you call &alarm()
it will really call Perl's alarm() once Larry puts it in.

At the end of the file is a sample file (talarm.pl) to test it to make sure
it works.  I had this for quite some time, but the package part of it was
broken (on every system I tried it on).  Apparently Larry fixed the part
which caused a problem in PL37, and it now works (at least on all of my
systems).

Enjoy.  Oh yes, this is in a perl-shar format.  Just save this to a file
and then perl -x _file_ and you will have alarm.pl and talarm.pl (which
will be set to be executable).

		-- Gordon.
-- 
Gordon C. Galligher	9127 Potter Rd. #2E	Des. Plaines, Ill.    60016-4881
     telxon!ping%gorpong@uunet.uu.net (not tested)  (Is this even legal??)
     ...!uunet!telxon!ping!gorpong      (tested)    (And it works!)
"It seems to me, Golan, that the advance of civilization is nothing but an
 exercise in the limiting of privacy." - Janov Pelorat -- _Foundation's Edge_

--------------------------snip-snip-snip-------------------------------------

#! perl
print STDERR "Extracting file:  alarm.pl\n";
open(OUT, "> alarm.pl") || die "Cannot open alarm.pl to write, $!\n";
print OUT <<'_THIS_IS_THE_END_';
###############################################################################
##									     ##
## ident: @(#)alarm.pl 1.0		PERL 3.0		9/4/90	     ##
##									     ##
###############################################################################
##
##	Modification History:
##
##		Opus 1.0
##		09/04/90 - Gordon C. Galligher  (gorpong@trevise.oca.com)
##			This package emulates the C-language alarm() routine
##			on all UNIX systems to cause a signal (-ALRM) to be 
##			sent to a process in x amount of time (seconds).  
##			This can be used for things such as setting an alarm 
##			and then waiting for input.  If the alarm comes in, 
##			you will be thrown into your signal handler (handling
##			$SIG{"ALRM"}).  An alarm time of zero (0) cancels
##			any impending alarms.
##
##			CAVEAT:
##				It should be noted that this will hardly be
##				as efficient as an alarm() function inside of
##				perl.  The alarm() function inside of perl,
##				if one existed, would use the subroutine
##				alarm() and it would not cause a forked process
##				to be created.  This function is to be used
##				until the alarm() function exists inside of
##				perl itself, if ever, and by those systems 
##				which do not have the alarm() system call
##				once alarm() is an internal function (if ever).
##
##			The first part of this file checks to see if an alarm
##			function does indeed exist internal to perl, and if it
##			does, whenever you call &alarm(), it will automatically
##			use the REAL alarm, not this hack.  That way if/when
##			alarm() becomes a builtin subroutine, your code will
##			not have to change.  (Oooh, upward compatibility, 
##			great stuff.)
##
##			If the alarm() function is ever put into perl, it 
##			really should have an alarm() and a ualarm().  The
##			ualarm() is a System V thingee, but can easily be
##			emulated with Berkeley's setitimer() routine (I know
##			because I have done this).
##
##############################################################################

package ALARM;					# Do not step on anyone

#
# Global variables to the ALARM package
#

    #
    # Does a real alarm() function exist?
    #
eval "alarm(10); alarm(0);";			# Set, then unset (to test)
if ( length($@) == 0 )
{
	$ALARMEXISTS = 1;			# Yeah, use alarm() in perl
}
else						# No, so make sure we can
{						# emulate it in here.
	($version, $patchlevel) = $] =~ /(\d+\.\d+).*\nPatch level: (\d+)/;
	die "Cannot use alarm() in pre-Perl 3.0 PL9 release.\n" 
		if $version < 3.0 || ($version >= 3.0 && $patchlevel < 9.0);
}

    #
    # Keep track if we've been called in the alarm() subroutine.
    #
$ALARMCALLED = 0;				# Not called yet.
$ALARMPPID   = 0;				# The Process ID to alarm
$ALARMCHILD  = 0;				# The child pid with the sleep

##
##  ALARM
##
##		ACCEPTS:
##			$time	 --	Scalar time until alarm in seconds
##
##		PERFORMS:
##			This function takes the time, in seconds, and then
##			sets itself to send an alarm signal (-ALRM) to the
##			calling process (via process id).  It then forks off
##			and the child does a sleep, while the parent returns
##			to the caller.  Now that I have read the manual page
##			on the real alarm(3c) function, I see that subsequent
##			calls to alarm() will override the previous settings,
##			with the special value of zero cancelling any previous
##			alarm.  That is how it shall be with this function.
##			The other thing which I see in the manual page is
##			that the alarm() subroutine will return the time 
##			remaining in the current alarm, if this is a 
##			subsequent call.  This is not an easy task, and it 
##			requires much more synchronization between the parent
##			and child processes.  This will be handled with a pair
##			of pipes set up by the parent before the fork, and when
##			the child receives the -ALRM signal, it will calculate
##			the time remaining before the alarm would be sent and
##			send that number through the pipe to the parent, and
##			then die.  The parent will then save that number, and
##			if the new number is greater than zero, it will open
##			up another pipe and then fork() for the child.  Once it
##			is done with all of this, it will return the number
##			of seconds remaining on the previous alarm (or zero)
##			to the caller (who will most likely ignore it :-(
##
##		RETURNS:
##			$secs	 --	Scalar number of seconds on prev. alarm
##
##  Gordon C. Galligher (9/4/90)  (gorpong)
##

sub main'alarm 
{
	local($time) = @_;			# Give me the time 'till alarm
	local($secs) = 0;			# The # of seconds left on alrm
	local($SIGCLD) = "ALRM";		# The signal to send to child

	if ( $ALARMEXISTS == 1 )		# The real thing exists, so
	{					# do not waste time on this
		return alarm($time);		# bogus frat.
	} # IF $ALARMEXISTS == 1

	if ( $ALARMCALLED != 0 )		# We have been called before,
	{					# so the set-up is easy.
		$ALARMCALLED = 0 if $time <= 0;	# Turn us off, if they do.
		kill $SIGCLD, $ALARMCHILD;	# Kill my child, (boo, hoo)
		$secs = <READCHILD>;		# Read the awaiting pid.
		close(READCHILD);		# We need it no longer.
		return $secs if $ALARMCALLED == 0;	# Return to the caller
	} # IF $ALARMCALLED == 0;

    #
    # This will happen in one of two cases:
    #	1).  We have been called for the first time
    #	2).  We have been called a subsequent time, with a $time greater
    #	     than zero, so we need to ignore what we previously were, and
    #	     set a new alarm for the new time.
    # If we were sent a $time == 0, to disable the alarm, then we will have
    # returned above and never will reach this code.
    #
    # ==NOTE==
    #	If we are the child, and we have awakened to see that we need to
    #	signal the other process to wake up, then we shall do so.  What we
    #	will do directly after that is write the number zero into the pipe
    #	to our direct parent (in case they attempt to cancel the alarm
    #	later (stupids)), and close the pipe.  After that, we sleep(5).
    #	While this alone does not appear to make much sense, we are doing
    #	this because the original parent may be sitting in a wait() waiting
    #	for its children to come back.  Well, if we exit() right away, then
    #	we will be the ones reported to the parent, and not the one the
    #	parent just killed (if the parent had also forked and used the wait 
    #	to kill the child[ren]).
    #	If you do not understand, then take the example program below and
    #	remove the sleep(5), and execute it.  You will see that the wait()
    #	does not return the process id of the child we think it does.  It
    #	actually returns the process id of the alarm()'s child (which is not
    #	what we want.
    #

	pipe(READCHILD, WRITECHILD);		# Give me read/write stuff.
	$ALARMPPID  = $$;			# Save this for the youngster
	$ALARMCHILD = fork();			# Now we have a child, maybe

	if ( $ALARMCHILD == -1 )		# Nope, we are barren.
	{
		die "Cannot fork() in alarm(), $!\n";
	} # IF $ALARMCHILD == -1
	elsif ( $ALARMCHILD == 0 )		# Yea, pass out the cigars!
	{					# We are now the child.
		local($mytime) = 0;		# The time from sleep.
		
		close(READCHILD);		# We no longer need it.
		select(WRITECHILD);		# Make it the current one.
		$| = 1;				# Make it unbuffered.
		select(STDOUT);			# Put it back.
		$mytime = sleep($time);		# Sleep this amount of time.
		kill "ALRM", $ALARMPPID unless $mytime < $time;
		$mytime = $time - $mytime;	# The difference of sleep-slept
		print WRITECHILD ($mytime < 0) ? 0 : $mytime;
		close(WRITECHILD);		# Close the pipe/flush it.
		sleep(5) if $mytime <= 0;	# Only sleep if we have killed
		exit(0);			# We are done here.
	} # IF $ALARMCHILD == 0
	else					# We are the parent
	{
		close(WRITECHILD);		# We no longer need it.
		$ALARMCALLED = 1;		# Now we have been called.
		$ALARM'SIG{"PIPE"} = 'IGNORE';	# Just ignore it.
		return $secs;			# Give this back to caller.
	} # ELSE..IF $ALARMCHILD ...
} # ALARM

###############################################################################
##		EXAMPLE FILE:  talarm.pl				     ##
###############################################################################
##
## Use this file to test and see if the alarm.pl file really works.
##
##--------------cut here and remove all ##'s in front of lines-----------------
###! /usr/local/bin/perl
##
##require	"ctime.pl";
##require	"alarm.pl";
##
##$MYCHILD = 0;
##
##sub sigalrm
##{
##	local($sig) = @_;
##
##	print STDERR "CAUGHT SIG$sig at:  ", &ctime(time);
##	print STDERR "KILLING CHILD:  $MYCHILD NOW\n";
##	kill "HUP", $MYCHILD;
##	kill "TERM", $MYCHILD;
##	kill "KILL", $MYCHILD;
##	print STDERR "CHILD SHOULD NOW BE DEAD\n";
##}
##
##$| = 1;
##select(STDERR); $| = 1; select(STDOUT);
##print "IT IS NOW:  ", &ctime(time());
##print "PID($$) FORK OFF\n";
##$MYCHILD = fork();
##if ( $MYCHILD == -1 )
##{
##	print "THEN AGAIN, I AM NOT FORKING OFF.\n";
##	exit(0);
##}
##elsif ( $MYCHILD == 0 )
##{
##	print "\tI AM THE CHILD ($$), AND I AM GOING TO CHEW UP SOME TIME\n";
##	while (1) {}
##}
##else
##{
##	print "I AM THE PARENT ($$), AND I AM SETTING AN ALARM FOR 10 SECONDS\n";
##	$SIG{'ALRM'} = "sigalrm";
##	&alarm(10);
##	print "I WILL NOW wait() FOR MY CHILD.\n";
##	$val = wait;
##	print "PARENT BACK, CANCELLING ALARM.\n";
##	$val2 = &alarm(0);
##	print "ALARM RETURNS:  $val2\n";
##	print "WAIT RETURNED:  $val\n";
##	print "STATUS OF CHILD:  $?\n";
##}
###############################################################################

1;					# Needed, or require will choke.
_THIS_IS_THE_END_

close(OUT);
print "Extracting file:  talarm.pl\n";
open(OUT, "> talarm.pl") || die "Cannot open talarm.pl to write, $!\n";
print OUT <<'_THIS_IS_THE_END_';
eval "exec /usr/local/bin/perl -S $0 $*"
	if $running_under_some_shell;

require	"ctime.pl";
require	"alarm.pl";

$MYCHILD = 0;

sub sigalrm
{
	local($sig) = @_;

	print "CAUGHT SIG$sig at:  ", &ctime(time);
	print "KILLING CHILD:  $MYCHILD NOW\n";
	kill "HUP", $MYCHILD;
	kill "TERM", $MYCHILD;
	kill "KILL", $MYCHILD;
	print "CHILD SHOULD NOW BE DEAD\n";
}

select(STDERR); $| = 1; select(STDOUT); $| = 1;
print "IT IS NOW:  ", &ctime(time());
print "PID($$) FORK OFF\n";
$MYCHILD = fork();
if ( $MYCHILD == -1 )
{
	print "THEN AGAIN, I AM NOT FORKING OFF.\n";
	exit(0);
}
elsif ( $MYCHILD == 0 )
{
	print "\tI AM THE CHILD ($$), AND I AM GOING TO CHEW UP SOME TIME\n";
	while (1) {}
}
else
{
	print "I AM THE PARENT ($$), AND I AM SETTING AN ALARM FOR 10 SECONDS\n";
	$SIG{'ALRM'} = "sigalrm";
	&alarm(10);
	print "I WILL NOW wait() FOR MY CHILD.\n";
	$val = wait;
	print "PARENT BACK, CANCELLING ALARM.\n";
	$val2 = &alarm(0);
	print "ALARM RETURNS:  $val2\n";
	print "WAIT RETURNED:  $val\n";
	print "STATUS OF CHILD:  $?\n";
}
_THIS_IS_THE_END_

close(OUT);
chmod 0755, "talarm.pl";
print "Execute:  talarm.pl to test the alarm function, and if works, you\n";
print "can install it into your system-wide perl-lib directory, or your own\n";
print "personal one if you do not have permission to the system-wide one.\n\n";
print "Good luck, and you may send e-mail to:  \n";
print "\t...uunet!telxon!teleng!ping!gorpong  if there are any problems.\n";
print "(Then again, you may want to wait for Larry to put a REAL alarm in)\n";

__END__