>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