>From 8669e7987e7d6bca564c658ca234b2994edd0984 Mon Sep 17 00:00:00 2001 From: Holger Hans Peter Freyther Date: Tue, 5 Apr 2011 20:51:37 +0200 Subject: [PATCH] timeout: Add code for timeout handling on BlockClosures Make it possible to terminate the execution of a BlockClosure after a given amount of time. This adds BlockClosure>>#timeout:do. --- configure.ac | 1 + packages/timeout/ChangeLog | 5 ++ packages/timeout/Timeout.st | 124 +++++++++++++++++++++++++++++++++++++++ packages/timeout/TimeoutTest.st | 63 ++++++++++++++++++++ packages/timeout/package.xml | 12 ++++ tests/testsuite.at | 1 + 6 files changed, 206 insertions(+), 0 deletions(-) create mode 100644 packages/timeout/ChangeLog create mode 100644 packages/timeout/Timeout.st create mode 100644 packages/timeout/TimeoutTest.st create mode 100644 packages/timeout/package.xml diff --git a/configure.ac b/configure.ac index a6aa1b5..93f4b89 100644 --- a/configure.ac +++ b/configure.ac @@ -588,6 +588,7 @@ GST_PACKAGE_ENABLE([Sport], [sport]) GST_PACKAGE_ENABLE([SUnit], [sunit]) GST_PACKAGE_ENABLE([Swazoo], [swazoo-httpd]) GST_PACKAGE_ENABLE([Sockets], [sockets], [], [gst_cv_sockets]) +GST_PACKAGE_ENABLE([Timeout], [timeout]) GST_PACKAGE_ENABLE([VFSAddOns], [vfs], [], [], [Makefile]) GST_PACKAGE_ENABLE([VisualGST], [visualgst]) GST_PACKAGE_ENABLE([XML-XMLNodeBuilder], [xml/builder]) diff --git a/packages/timeout/ChangeLog b/packages/timeout/ChangeLog new file mode 100644 index 0000000..b0f4ee9 --- /dev/null +++ b/packages/timeout/ChangeLog @@ -0,0 +1,5 @@ +2011-04-05 Holger Hans Peter Freyther + + * package.xml: Add initial version. + * Timeout.st: Add initial version. + * TimeoutTest.st: Add initial version. diff --git a/packages/timeout/Timeout.st b/packages/timeout/Timeout.st new file mode 100644 index 0000000..91d856e --- /dev/null +++ b/packages/timeout/Timeout.st @@ -0,0 +1,124 @@ +"====================================================================== +| +| BlockClosure Extensions for Timeouts +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2011 +| Free Software Foundation, Inc. +| Written by Holger Hans Peter Freyther. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + +Namespace current: Smalltalk [ +Notification subclass: TimeoutNotification [ + | blk | + + + + TimeoutNotification class >> on: aBlk [ + + ^ self new + block: aBlk; yourself + ] + + block: aBlock [ + + blk := aBlock + ] + + block [ + + ^ blk + ] + + isResumable [ + + ^ false + ] +] +] + +Process extend [ + signalInterrupt: anException [ + + self interruptLock critical: + [| block | + self isActive + ifTrue: + [anException signal. + ^self]. + block := [self evaluate: [anException signal] + ifNotTerminated: [self resume]]. + suspendedContext := block asContext: suspendedContext. + self resume] + ] +] + +BlockClosure extend [ + timeout: seconds do: aBlock [ + + "I will execute myself for up to seconds and if a timeout + occurs I will invoke the aBlock. If the timeout occurs early + not much of the block is executed yet. I also have some issues + with Delays and not breaking these properly. + " + | delay sem proc value timeout | + + "Use the semaphore to signal that we executed everything" + sem := Semaphore new. + + "Remember the current process" + proc := Processor activeProcess. + + timeout := false. + + "Start the waiting." + [[ + + "Start a process to wait in and then signal" + [| delay | + delay := Delay forSeconds: seconds. + + "Wait and see if it is timed out. If so send a signal." + (delay timedWaitOn: sem) ifTrue: [ + proc signalInterrupt: (TimeoutNotification on: self). + ]. + ] fork. + + value := self value. + ] ensure: [sem signal] + ] on: TimeoutNotification do: [:e | + e block = self + ifTrue: [timeout := true] + ifFalse: [e pass]. + ]. + + "Make sure we call the ensure's first." + ^ timeout + ifTrue: [^aBlock value] + ifFalse: [^value]. + ] +] diff --git a/packages/timeout/TimeoutTest.st b/packages/timeout/TimeoutTest.st new file mode 100644 index 0000000..a73a25c --- /dev/null +++ b/packages/timeout/TimeoutTest.st @@ -0,0 +1,63 @@ +"====================================================================== +| +| BlockClosure Extensions for Timeouts Tests +| +| + ======================================================================" + +"====================================================================== +| +| Copyright 2011 +| Free Software Foundation, Inc. +| Written by Holger Hans Peter Freyther. +| +| This file is part of the GNU Smalltalk class library. +| +| The GNU Smalltalk class library is free software; you can redistribute it +| and/or modify it under the terms of the GNU Lesser General Public License +| as published by the Free Software Foundation; either version 2.1, or (at +| your option) any later version. +| +| The GNU Smalltalk class library is distributed in the hope that it will be +| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of +| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser +| General Public License for more details. +| +| You should have received a copy of the GNU Lesser General Public License +| along with the GNU Smalltalk class library; see the file COPYING.LIB. +| If not, write to the Free Software Foundation, 59 Temple Place - Suite +| 330, Boston, MA 02110-1301, USA. +| + ======================================================================" + +TestCase subclass: TimeoutTest [ + testSingleDelay [ + | events | + events := OrderedCollection new. + + "Make sure things are timing out" + [ + [(Delay forSeconds: 1000000) wait.] ensure: [events add: 'ensure']. + ] timeout: 1 do: [events add: 'timeout']. + + self assert: events asArray = #('ensure' 'timeout') + ] + + testNestedTimeouts [ + | events | + + events := OrderedCollection new. + + [ + [ + [ + [ + [(Delay forSeconds: 100000) wait. ] ensure: [events add: 'ensure-in']. + ] timeout: 1000000 do: [events add: 'timeout-inner']. + ] ensure: [events add: 'ensure-mid']. + ] timeout: 1 do: [events add: 'timeout']. + ] ensure: [events add: 'ensure-out']. + + self assert: events asArray = #('ensure-in' 'ensure-mid' 'timeout' 'ensure-out'). + ] +] diff --git a/packages/timeout/package.xml b/packages/timeout/package.xml new file mode 100644 index 0000000..247b720 --- /dev/null +++ b/packages/timeout/package.xml @@ -0,0 +1,12 @@ + + Timeout + Timeout + + Timeout.st + + + Timeout.TimeoutTest + TimeoutTest.st + + + diff --git a/tests/testsuite.at b/tests/testsuite.at index ffa3919..bb839b2 100644 --- a/tests/testsuite.at +++ b/tests/testsuite.at @@ -163,6 +163,7 @@ AT_OPTIONAL_PACKAGE_TEST([Seaside-Core]) AT_OPTIONAL_PACKAGE_TEST([Sockets], [AT_XFAIL_IF(:)]) AT_PACKAGE_TEST([Sport]) AT_PACKAGE_TEST([Swazoo]) +AT_PACKAGE_TEST([Timeout]) AT_OPTIONAL_PACKAGE_TEST([XML-XMLParser]) AT_OPTIONAL_PACKAGE_TEST([XML-Expat]) AT_OPTIONAL_PACKAGE_TEST([ZLib]) -- 1.7.4