On 04/06/2011 11:42 AM, Paolo Bonzini wrote: > > Yes, thanks for putting up with me. :)
Thanks for your time and input. Feel free to remove the syntactic sugar part or ask me to do it. holger
>From 2fcfda5f234827a95f680732a5029326dc720279 Mon Sep 17 00:00:00 2001 From: Holger Hans Peter Freyther <[email protected]> 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 | 132 +++++++++++++++++++++++++++++++++++++++ packages/timeout/TimeoutTest.st | 99 +++++++++++++++++++++++++++++ packages/timeout/package.xml | 12 ++++ tests/testsuite.at | 1 + 6 files changed, 250 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 85f6c6c..b43092e 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..5db49cc --- /dev/null +++ b/packages/timeout/ChangeLog @@ -0,0 +1,5 @@ +2011-04-11 Holger Hans Peter Freyther <[email protected]> + + * 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..8027981 --- /dev/null +++ b/packages/timeout/Timeout.st @@ -0,0 +1,132 @@ +"====================================================================== +| +| 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 [ + | delay | + <category: 'Language-Implementation'> + <comment: 'I get send by the timeout handling of a Delay +and I am the indication that the time is up and that one should come +to an end.'> + + TimeoutNotification class >> on: aDelay [ + <category: 'creation'> + ^ self new + delay: aDelay; yourself + ] + + delay: aDelay [ + <category: 'private'> + delay := aDelay + ] + + delay [ + <category: 'private'> + ^ delay + ] + + isResumable [ + <category: 'private'> + ^ false + ] +] +] + +Process extend [ + signalInterrupt: anException [ + <category: '*timeout-private'> + self interruptLock critical: + [| block | + self isActive + ifTrue: + [anException signal. + ^self]. + block := [self evaluate: [anException signal] + ifNotTerminated: [self resume]]. + suspendedContext := block asContext: suspendedContext. + self resume] + ] +] + +Delay extend [ + value: aBlock onTimeoutDo: aTimeoutBlock [ + <category: '*timeout-private'> + "I will execute myself for up to the time of my own delay + and in case the code didn't finish I will abort the execution, + unwind the block and then evaluate the passed time out block. + " + | 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" + [ + "Wait and see if it is timed out. If so send a signal." + (self timedWaitOn: sem) ifTrue: [ + proc signalInterrupt: (TimeoutNotification on: self). + ]. + ] fork. + + value := aBlock ensure: [sem signal]. + ] on: TimeoutNotification do: [:e | + e delay = self + ifTrue: [timeout := true] + ifFalse: [e pass]. + ]. + + "Make sure we call the ensure's first." + ^ timeout + ifTrue: [aTimeoutBlock value] + ifFalse: [value]. + ] +] + +BlockClosure extend [ + timeout: seconds do: aBlock [ + <category: '*timeout-private'> + "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 forSeconds: 3) value: self onTimeoutDo: aBlock. + ] +] diff --git a/packages/timeout/TimeoutTest.st b/packages/timeout/TimeoutTest.st new file mode 100644 index 0000000..fd49b53 --- /dev/null +++ b/packages/timeout/TimeoutTest.st @@ -0,0 +1,99 @@ +"====================================================================== +| +| 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: TimeoutTestDelay [ + testSingleDelay [ + | events | + events := OrderedCollection new. + + "Make sure things are timing out" + (Delay forSeconds: 1) + value: + [[(Delay forSeconds: 1000000) wait.] + ensure: [events add: 'ensure']] + onTimeoutDo: [events add: 'timeout']. + + self assert: events asArray = #('ensure' 'timeout') + ] + + testNestedTimeouts [ + | events | + + events := OrderedCollection new. + + [ + (Delay forSeconds: 1) + value: [ + [ + (Delay forSeconds: 100000) + value: [[(Delay forSeconds: 10000) wait] ensure: + [events add: 'ensure-in']] + onTimeoutDo: [events add: 'timeout-inner']. + ] ensure: [events add: 'ensure-mid']] + onTimeoutDo: [events add: 'timeout']. + ] ensure: [events add: 'ensure-out']. + + self assert: events asArray = #('ensure-in' 'ensure-mid' 'timeout' 'ensure-out'). + ] +] + +TestCase subclass: TimeoutTestBlock [ + 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..add2df4 --- /dev/null +++ b/packages/timeout/package.xml @@ -0,0 +1,12 @@ +<package> + <name>Timeout</name> + <namespace>Timeout</namespace> + + <filein>Timeout.st</filein> + + <test> + <sunit>Timeout.TimeoutTestBlock</sunit> + <sunit>Timeout.TimeoutTestDelay</sunit> + <filein>TimeoutTest.st</filein> + </test> +</package> 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.2
_______________________________________________ help-smalltalk mailing list [email protected] http://lists.gnu.org/mailman/listinfo/help-smalltalk
