clipper@chan.csd.uwo.ca (Khun Yee Fung) (10/29/90)
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. Khun Yee clipper@csd.uwo.ca -- ---- In Real life: Khun Yee Fung clipper@csd.uwo.ca (Internet) Alternative: 4054_3267@UWOVAX.BITNET UUCP: ...!{ihnp4|decvax|seismo}!{watmath|utzoo}!ria!csd!clipper Department of Computer Science Middlesex College The University of Western Ontario London, Ontario, N6A 5B7 CANADA
lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) (10/30/90)
In article <CLIPPER.90Oct28162238@chan.csd.uwo.ca> clipper@chan.csd.uwo.ca (Khun Yee Fung) writes:
: 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.
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().
I'm still resisting adding gethostname, since there doesn't seem to be
a portable definition of what a host name actually is, where you derive it
from and whether it contains the domain. Not to mention the business that
gateways can have multiple names, one for each interface...
Larry
worley@compass.uucp (Dale Worley) (10/31/90)
Well, here's the code I use: #! /usr/local/bin/perl # Interval to re-read the information, in seconds $interval = 60; # Set the timer to go off in 1 second, and every $interval seconds # thereafter. Call &get_info when it goes off. do '/compass/c/worley/perl-3.0/sys/syscall.h'; $SIG{'ALRM'} = 'get_info'; $value = pack('LLLL', $interval, 0, 1, 0); syscall(&SYS_setitimer, 0, $value, 0); (Of course, you have to use the correct directory for your syscall.h Perl header file.) The crux of the problem is that alarm() isn't a system call, it is a library routine that calls setitimer() (on BDS 4.2 systems, anyway). You can do setitimer() pretty straightforwardly using Perl's syscall(). Don't forget that the name of the signal is ALRM, not ALARM! (Elements of %SIG that don't correspond to real signal names have no effect...) Dale Worley Compass, Inc. worley@compass.com -- I try to make everyone's day a little more surreal.
gorpong@uunet.uu.net (10/31/90)
<> 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__
clipper@chan.csd.uwo.ca (Khun Yee Fung) (10/31/90)
Thank you very much for the code to do alarm(). I tried both of them and they both worked. Thank you Larry for adding it in the next patch. I also found the error I committed when I used the various codes written by others and myself, all using syscall(). I used a return statement in the interrupt subroutine. It produced a Segmentation fault error. If I used a return statement in the code written by <worley@compass.uucp>, the same error would be produced (on my machine anyway). I wonder why. Anybody has any idea? Just curious. #! /usr2/new/bin/perl # Interval to re-read the information, in seconds $interval = 1; # Set the timer to go off in 1 second, and every $interval seconds # thereafter. Call &get_info when it goes off. require 'syscall.h'; $SIG{'ALRM'} = 'get_info'; $value = pack('LLLL', $interval, 0, 1, 0); syscall(&SYS_setitimer, 0, $value, 0); while (1) { } sub get_info { print "get_info\n"; # Have a return here will produce a Segmentation fault error on a # sun 3/50 running SunOS 4.03 # return; } -- ---- In Real life: Khun Yee Fung clipper@csd.uwo.ca (Internet) Alternative: 4054_3267@UWOVAX.BITNET UUCP: ...!{ihnp4|decvax|seismo}!{watmath|utzoo}!ria!csd!clipper Department of Computer Science Middlesex College The University of Western Ontario London, Ontario, N6A 5B7 CANADA
lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) (11/01/90)
In article <CLIPPER.90Oct31104736@chan.csd.uwo.ca> clipper@chan.csd.uwo.ca (Khun Yee Fung) writes:
: I also found the error I committed when I used the various codes
: written by others and myself, all using syscall(). I used a return
: statement in the interrupt subroutine. It produced a Segmentation
: fault error. If I used a return statement in the code written by
: <worley@compass.uucp>, the same error would be produced (on my machine
: anyway). I wonder why. Anybody has any idea? Just curious.
Same reason return didn't work in a sort subroutine. It'll be fixed in 38.
Larry
tchrist@convex.COM (Tom Christiansen) (11/01/90)
In article <CLIPPER.90Oct28162238@chan.csd.uwo.ca> clipper@chan.csd.uwo.ca (Khun Yee Fung) writes: >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. I've posted this at least twice before. Here's get and set itimer, plus an alarm that groks floats. --tom #! /bin/sh # This is a shell archive, meaning: # 1. Remove everything above the #! /bin/sh line. # 2. Save the resulting text in a file. # 3. Execute the file with /bin/sh (not csh) to create: # ttimer # itimers.pl # This archive created: Wed Oct 31 15:13:29 1990 export PATH; PATH=/bin:/usr/bin:$PATH echo shar: "extracting 'ttimer'" '(624 characters)' if test -f 'ttimer' then echo shar: "will not over-write existing file 'ttimer'" else sed 's/^ X//' << \SHAR_EOF > 'ttimer' X#!/usr/bin/perl X Xrequire 'itimers.pl'; Xrequire 'ctime.pl'; X X$| = 1; X X$SIG{'ALRM'} = 'bingo'; X Xsub bingo { X print "ALARM @ ", &ctime(time); X $hit++; X} X Xprint "alarm 7 @ ", &ctime(time); X Xdo alarm(7); X Xprint "sleeping 2 seconds... "; X Xsleep 2; X Xprintf "alarm had %g secs left\n", &alarm(0); X Xprint "resetting to 1.25 seconds\n"; X X&alarm(1.25); X Xdo { &timeleft; } until $hit; X Xprint "escaped at \n\t", &ctime(time); X Xsub timeleft { X local($timeleft); X &getitimer(&ITIMER_REAL, $timeleft) || die "can't getitimer: $!"; X ($x, $y, $s, $u) = &itimer($timeleft); X printf("timeleft is %g\n", $s + ($u / 1e6)); X} SHAR_EOF if test 624 -ne "`wc -c < 'ttimer'`" then echo shar: "error transmitting 'ttimer'" '(should have been 624 characters)' fi chmod 775 'ttimer' fi echo shar: "extracting 'itimers.pl'" '(2221 characters)' if test -f 'itimers.pl' then echo shar: "will not over-write existing file 'itimers.pl'" else sed 's/^ X//' << \SHAR_EOF > 'itimers.pl' X# itimers.pl - timer manipulation functions X# written by tom christiansen <tchrist@convex.com> X# X# getitimer, setitimer - like syscalls but return true on success X# NB: require packed data for args X# X# itimer - conversion function for packing and X# unpacking itimers. packs in scalar context, X# unpacks in array context. X# X# alarm - like libc call but can take and returns floats X# X Xrequire 'sizeof.ph'; Xrequire 'syscall.ph'; Xrequire 'sys/time.ph'; X X# X# careful: implementation dependent! X# X$itimer_t = 'L4'; # itimers consist of four longs X$sizeof{'itimer'} = '16' unless defined $sizeof{'itimer'}; # from sizeof.ph? X X########################################################################### X# itimer conversion function; this one goes both ways X# Xsub itimer { X if (wantarray) { X warn "itimer: only expected one arg in array context" if $#_; X warn "itimer: itimer to unpack not length ".$sizeof{'itimer'} X unless length($_[0]) == $sizeof{'itimer'}; X return unpack($itimer_t, $_[0]); X } else { X return pack($itimer_t, $_[0], $_[1], $_[2], $_[3]); X } X} X X X########################################################################### Xsub setitimer { X local($which) = shift; X local($retval); X X die "setitimer: input itimer not length ".$sizeof{'itimer'} X unless length($_[0]) == $sizeof{'itimer'}; X X $_[1] = &itimer(0,0,0,0); X syscall(&SYS_setitimer, $which, $_[0], $_[1]) != -1; X} X X########################################################################### Xsub getitimer { X local($which) = shift; X X $_[0] = &itimer(0,0,0,0); X X syscall(&SYS_getitimer, $which, $_[0]) != -1; X} X X########################################################################### X# X# alarm; send me a SIGALRM in this many seconds (fractions ok) X# X# Xsub alarm { X local($ticks) = @_; X local($itimer,$otimer); X local($isecs, $iusecs, $secs, $usecs); X X $secs = int($ticks); X $usecs = ($ticks - $secs) * 1e6; X X $otimer = &itimer(0,0,0,0); X $itimer = &itimer(0,0,$secs,$usecs); X X &setitimer(&ITIMER_REAL, $itimer, $otimer) X || warn "alarm: setitimer failed: $!"; X X ($isecs, $iusecs, $secs, $usecs) = &itimer($otimer); X return $secs + ($usecs/1e6); X} SHAR_EOF if test 2221 -ne "`wc -c < 'itimers.pl'`" then echo shar: "error transmitting 'itimers.pl'" '(should have been 2221 characters)' fi chmod 664 'itimers.pl' fi exit 0 # End of shell archive
gorpong@ping.uucp (Gordon C. Galligher) (11/02/90)
In article <1990Oct30.194343.27499@uvaarpa.Virginia.EDU> worley@compass.uucp writes: >Well, here's the code I use: [..example using setitimer..] >4.2 systems, anyway). You can do setitimer() pretty straightforwardly I believe that setitimer only exists on BSD flavors of UNIX, and a solution based on this approach would be non-portable. Then again, I may be wrong, all I know is it does not exist on this here SCO UNIX box, which conforms to the SVID (System V Interface Definition). -- 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_
allbery@NCoast.ORG (Brandon S. Allbery KB8JRR) (11/03/90)
As quoted from <108017@convex.convex.com> by tchrist@convex.COM (Tom Christiansen): +--------------- | In article <CLIPPER.90Oct28162238@chan.csd.uwo.ca> clipper@chan.csd.uwo.ca (Khun Yee Fung) writes: | >I have tried to do Perl's equivalence of alarm() on and off for two | | I've posted this at least twice before. Here's get and set itimer, | plus an alarm that groks floats. +--------------- Now try posting one that works under System V. ++Brandon -- Me: Brandon S. Allbery VHF/UHF: KB8JRR on 220, 2m, 440 Internet: allbery@NCoast.ORG Packet: KB8JRR @ WA8BXN America OnLine: KB8JRR AMPR: KB8JRR.AmPR.ORG [44.70.4.88] uunet!usenet.ins.cwru.edu!ncoast!allbery Delphi: ALLBERY