Index: tsmf/test-client.tcl ================================================================== --- tsmf/test-client.tcl +++ tsmf/test-client.tcl @@ -1,9 +1,8 @@ #! /usr/bin/env tclsh lappend auto_path [file join [file dirname [info script]] lib] -lappend auto_path [file join [file dirname [info script]] test-lib] lappend auto_path [file join [file dirname [info script]] ..] package require tsmf proc maxlen {list} { set maxlen 0 DELETED tsmf/test-lib/promise-1.1.0.tm Index: tsmf/test-lib/promise-1.1.0.tm ================================================================== --- tsmf/test-lib/promise-1.1.0.tm +++ tsmf/test-lib/promise-1.1.0.tm @@ -1,1298 +0,0 @@ -# Copyright (c) 2015, Ashok P. Nadkarni -# All rights reserved. - -# Redistribution and use in source and binary forms, with or without -# modification, are permitted provided that the following conditions are -# met: - -# 1. Redistributions of source code must retain the above copyright -# notice, this list of conditions and the following disclaimer. - -# 2. Redistributions in binary form must reproduce the above copyright -# notice, this list of conditions and the following disclaimer in the -# documentation and/or other materials provided with the distribution. - -# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -# HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -package require Tcl 8.6 - -namespace eval promise { - proc version {} { return 1.1.0 } -} - -proc promise::lambda {params body args} { - # Creates an anonymous procedure and returns a command prefix for it. - # params - parameter definitions for the procedure - # body - body of the procedures - # args - additional arguments to be passed to the procedure when it - # is invoked - # - # This is just a convenience command since anonymous procedures are - # commonly useful with promises. The lambda package from tcllib - # is identical in function. - - return [list ::apply [list $params $body] {*}$args] -} - -catch {promise::Promise destroy} -oo::class create promise::Promise { - - # The promise state can be one of - # PENDING - Initial state where it has not yet been assigned a - # value or error - # FULFILLED - The promise has been assigned a value - # REJECTED - The promise has been assigned an error - # CHAINED - The promise is attached to another promise - variable _state - - # Stores data that is accessed through the setdata/getdata methods. - # The Promise class itself does not use this. - variable _clientdata - - # The promise value once it is fulfilled or rejected. In the latter - # case, it should be an the error message - variable _value - - # The error dictionary in case promise is rejected - variable _edict - - # Reactions to be notified when the promise is rejected. Each element - # in this list is a pair consisting of the fulfilment reaction - # and the rejection reaction. Either element of the pair could be - # empty signifying no reaction for that case. The list is populated - # via the then method. - variable _reactions - - # Reference counting to free up promises since Tcl does not have - # garbage collection for objects. Garbage collection via reference - # counting only takes place after at least one done/then reaction - # is placed on the event queue, not before. Else promises that - # are immediately resolved on construction would be freed right - # away before the application even gets a chance to call done/then. - variable _do_gc - variable _nrefs - - # If no reject reactions are registered, then the Tcl bgerror - # handler is invoked. But don't want to do this more than once - # so track it - variable _bgerror_done - - constructor {cmd} { - # Create a promise for the asynchronous operation to be initiated - # by $cmd. - # cmd - a command prefix that should initiate an asynchronous - # operation. - # The command prefix $cmd is passed an additional argument - the - # name of this Promise object. It should arrange for one of the - # object's settle methods [fulfill], [chain] or - # [reject] to be called when the operation completes. - - set _state PENDING - set _reactions [list ] - set _do_gc 0 - set _bgerror_done 0 - set _nrefs 0 - array set _clientdata {} - - # Errors in the construction command are returned via - # the standard mechanism of reject. - # - if {[catch { - # For some special cases, $cmd may be "" if the async operation - # is initiated outside the constructor. This is not a good - # thing because the error in the initiator will not be - # trapped via the standard promise error catching mechanism - # but that's the application's problem (actually pgeturl also - # uses this). - if {[llength $cmd]} { - uplevel #0 [linsert $cmd end [self]] - } - } msg edict]} { - my reject $msg $edict - } - } - - destructor { - # Destroys the object. - # - # This method should not be generally called directly as [Promise] - # objects are garbage collected either automatically or via the [ref] - # and [unref] methods. - } - - method state {} { - # Returns the current state of the promise. - # - # The promise state may be one of the values 'PENDING', - # 'FULFILLED', 'REJECTED' or 'CHAINED' - return $_state - } - - method getdata {key} { - # Returns data previously stored through the setdata method. - # key - key whose associated values is to be returned. - # An error will be raised if no value is associated with the key. - return $_clientdata($key) - } - - method setdata {key value} { - # Sets a value to be associated with a key. - # key - the lookup key - # value - the value to be associated with the key - # A promise internally maintains a dictionary whose values can - # be accessed with the [getdata] and [setdata] methods. This - # dictionary is not used by the Promise class itself but is meant - # to be used by promise library specializations or applications. - # Callers need to take care that keys used for a particular - # promise are sufficiently distinguishable so as to not clash. - # - # Returns the value stored with the key. - set _clientdata($key) $value - } - - method value {} { - # Returns the settled value for the promise. - # - # The returned value may be the fulfilled value or the rejected - # value depending on whether the associated operation was successfully - # completed or failed. - # - # An error is raised if the promise is not settled yet. - if {$_state ni {FULFILLED REJECTED}} { - error "Value is not set." - } - return $_value - } - - method ref {} { - # Increments the reference count for the object. - incr _nrefs - } - - method unref {} { - # Decrements the reference count for the object. - # - # The object may have been destroyed when the call returns. - incr _nrefs -1 - my GC - } - - method nrefs {} { - # Returns the current reference count. - # - # Use for debugging only! Note, internal references are not included. - return $_nrefs - } - - method GC {} { - if {$_nrefs <= 0 && $_do_gc && [llength $_reactions] == 0} { - my destroy - } - } - - method FulfillAttached {value} { - if {$_state ne "CHAINED"} { - return - } - set _value $value - set _state FULFILLED - my ScheduleReactions - return - } - - method RejectAttached {reason edict} { - if {$_state ne "CHAINED"} { - return - } - set _value $reason - set _edict $edict - set _state REJECTED - my ScheduleReactions - return - } - - # Method to invoke to fulfil a promise with a value or another promise. - method fulfill {value} { - # Fulfills the promise. - # value - the value with which the promise is fulfilled - # - # Returns '0' if promise had already been settled and '1' if - # it was fulfilled by the current call. - - #ruff - # If the promise has already been settled, the method has no effect. - if {$_state ne "PENDING"} { - return 0; # Already settled - } - - #ruff - # Otherwise, it is transitioned to the 'FULFILLED' state with - # the value specified by $value. If there are any fulfillment - # reactions registered by the [done] or [then] methods, they - # are scheduled to be run. - set _value $value - set _state FULFILLED - my ScheduleReactions - return 1 - } - - # Method to invoke to fulfil a promise with a value or another promise. - method chain {promise} { - # Chains the promise to another promise. - # promise - the [Promise] object to which this promise is to - # be chained - # - # Returns '0' if promise had already been settled and '1' otherwise. - - #ruff - # If the promise on which this method is called - # has already been settled, the method has no effect. - if {$_state ne "PENDING"} { - return 0; - } - - #ruff - # Otherwise, it is chained to $promise so that it reflects that - # other promise's state. - if {[catch { - $promise done [namespace code {my FulfillAttached}] [namespace code {my RejectAttached}] - } msg edict]} { - my reject $msg $edict - } else { - set _state CHAINED - } - - return 1 - } - - method reject {reason {edict {}}} { - # Rejects the promise. - # reason - a message string describing the reason for the rejection. - # edict - a Tcl error dictionary - # - # The $reason and $edict values are passed on to the rejection - # reactions. By convention, these should be of the form returned - # by the `catch` or `try` commands in case of errors. - # - # Returns '0' if promise had already been settled and '1' if - # it was rejected by the current call. - - #ruff - # If the promise has already been settled, the method has no effect. - if {$_state ne "PENDING"} { - return 0; # Already settled - } - - #ruff - # Otherwise, it is transitioned to the 'REJECTED' state. If - # there are any reject reactions registered by the [done] or - # [then] methods, they are scheduled to be run. - - set _value $reason - #ruff - # If $edict is not specified, or specified as an empty string, - # a suitable error dictionary is constructed in its place - # to be passed to the reaction. - if {$edict eq ""} { - catch {throw {PROMISE REJECTED} $reason} - edict - } - set _edict $edict - set _state REJECTED - my ScheduleReactions - return 1 - } - - # Internal method to queue all registered reactions based on - # whether the promise is succesfully fulfilled or not - method ScheduleReactions {} { - if {$_state ni {FULFILLED REJECTED} || [llength $_reactions] == 0 } { - # Promise is not settled or no reactions registered - return - } - - # Note on garbage collection: garbage collection is to be enabled if - # at least one FULFILLED or REJECTED reaction is registered. - # Also if the promise is REJECTED but no rejection handlers are run - # we also schedule a background error. - # In all cases, CLEANUP reactions do not count. - foreach reaction $_reactions { - foreach type {FULFILLED REJECTED} { - if {[dict exists $reaction $type]} { - set _do_gc 1 - if {$type eq $_state} { - set cmd [dict get $reaction $type] - if {[llength $cmd]} { - if {$type eq "FULFILLED"} { - lappend cmd $_value - } else { - lappend cmd $_value $_edict - } - set ran_reaction($type) 1 - # Enqueue the reaction via the event loop - after 0 [list after idle $cmd] - } - } - } - } - if {[dict exists $reaction CLEANUP]} { - set cmd [dict get $reaction CLEANUP] - if {[llength $cmd]} { - # Enqueue the cleaner via the event loop passing the - # *state* as well as the value - if {$_state eq "REJECTED"} { - lappend cmd $_state $_value $_edict - } else { - lappend cmd $_state $_value - } - after 0 [list after idle $cmd] - # Note we do not set _do_gc if we only run cleaners - } - } - } - set _reactions [list ] - - # Check for need to background error (see comments above) - if {$_state eq "REJECTED" && $_do_gc && ! [info exists ran_reaction(REJECTED)] && ! $_bgerror_done} { - # TBD - should we also check _nrefs before backgrounding error? - - # Wrap in catch in case $_edict does not follow error conventions - # or is not even a dictionary - if {[catch { - dict get $_edict -level - dict get $_edict -code - }]} { - catch {throw {PROMISE REJECT} $_value} - edict - } else { - set edict $_edict - } - # TBD - how exactly is level to be handled? - # If -level is not 0, bgerror barfs because it treates - # it as TCL_RETURN no matter was -code is - dict set edict -level 0 - after idle [interp bgerror {}] [list $_value $edict] - set _bgerror_done 1 - } - - my GC - return - } - - method RegisterReactions {args} { - # Registers the specified reactions. - # args - dictionary keyed by 'CLEANUP', 'FULFILLED', 'REJECTED' - # with values being the corresponding reaction callback - - lappend _reactions $args - my ScheduleReactions - return - } - - method done {{on_fulfill {}} {on_reject {}}} { - # Registers reactions to be run when the promise is settled. - # on_fulfill - command prefix for the reaction to run - # if the promise is fulfilled. - # reaction is registered. - # on_reject - command prefix for the reaction to run - # if the promise is rejected. - # Reactions are called with an additional argument which is - # the value with which the promise was settled. - # - # The command may be called multiple times to register multiple - # reactions to be run at promise settlement. If the promise was - # already settled at the time the call was made, the reactions - # are invoked immediately. In all cases, reactions are not called - # directly, but are invoked by scheduling through the event loop. - # - # The method triggers garbage collection of the object if the - # promise has been settled and any registered reactions have been - # scheduled. Applications can hold on to the object through - # appropriate use of the [ref] and [unref] methods. - # - # Note that both $on_fulfill and $on_reject may be specified - # as empty strings if no further action needs to be taken on - # settlement of the promise. If the promise is rejected, and - # no rejection reactions are registered, the error is reported - # via the Tcl 'interp bgerror' facility. - - # TBD - as per the Promise/A+ spec, errors in done should generate - # a background error (unlike then). - - my RegisterReactions FULFILLED $on_fulfill REJECTED $on_reject - - #ruff - # The method does not return a value. - return - } - - method then {on_fulfill {on_reject {}}} { - # Registers reactions to be run when the promise is settled - # and returns a new [Promise] object that will be settled by the - # reactions. - # on_fulfill - command prefix for the reaction to run - # if the promise is fulfilled. If an empty string, no fulfill - # reaction is registered. - # on_reject - command prefix for the reaction to run - # if the promise is rejected. If unspecified or an empty string, - # no reject reaction is registered. - # Both reactions are called with an additional argument which is - # the value with which the promise was settled. - # - # The command may be called multiple times to register multiple - # reactions to be run at promise settlement. If the promise was - # already settled at the time the call was made, the reactions - # are invoked immediately. In all cases, reactions are not called - # directly, but are invoked by scheduling through the event loop. - # - # If the reaction that is invoked runs without error, its return - # value fulfills the new promise returned by the 'then' method. - # If it raises an exception, the new promise will be rejected - # with the error message and dictionary from the exception. - # - # Alternatively, the reactions can explicitly invoke commands - # [then_fulfill], [then_reject] or [then_chain] to - # resolve the returned promise. In this case, the return value - # (including exceptions) from the reactions are ignored. - # - # If 'on_fulfill' (or 'on_reject') is an empty string (or unspecified), - # the new promise is created and fulfilled (or rejected) with - # the same value that would have been passed in to the reactions. - # - # The method triggers garbage collection of the object if the - # promise has been settled and registered reactions have been - # scheduled. Applications can hold on to the object through - # appropriate use of the [ref] and [unref] methods. - # - # Returns a new promise that is settled by the registered reactions. - - set then_promise [[self class] new ""] - my RegisterReactions \ - FULFILLED [list ::promise::_then_reaction $then_promise FULFILLED $on_fulfill] \ - REJECTED [list ::promise::_then_reaction $then_promise REJECTED $on_reject] - return $then_promise - } - - # This could be a forward, but then we cannot document it via ruff! - method catch {on_reject} { - # Registers reactions to be run when the promise is rejected. - # on_reject - command prefix for the reaction - # reaction to run if the promise is rejected. If unspecified - # or an empty string, no reject reaction is registered. The - # reaction is called with an additional argument which is the - # value with which the promise was settled. - # This method is just a wrapper around [then] with the - # 'on_fulfill' parameter defaulting to an empty string. See - # the description of that method for details. - return [my then "" $on_reject] - } - - method cleanup {cleaner} { - # Registers a reaction to be executed for running cleanup - # code when the promise is settled. - # cleaner - command prefix to run on settlement - # This method is intended to run a clean up script - # when a promise is settled. Its primary use is to avoid duplication - # of code in the `then` and `catch` handlers for a promise. - # It may also be called multiple times - # to clean up intermediate steps when promises are chained. - # - # The method returns a new promise that will be settled - # as per the following rules. - # - if the cleaner runs without errors, the returned promise - # will reflect the settlement of the promise on which this - # method is called. - # - if the cleaner raises an exception, the returned promise - # is rejected with a value consisting of the error message - # and dictionary pair. - # - # Returns a new promise that is settled based on the cleaner - set cleaner_promise [[self class] new ""] - my RegisterReactions CLEANUP [list ::promise::_cleanup_reaction $cleaner_promise $cleaner] - return $cleaner_promise - } -} - -proc promise::_then_reaction {target_promise status cmd value {edict {}}} { - # Run the specified command and fulfill/reject the target promise - # accordingly. If the command is empty, the passed-in value is passed - # on to the target promise. - - # IMPORTANT!!!! - # MUST BE CALLED FROM EVENT LOOP AT so info level must be 1. Else - # promise::then_fulfill/then_reject/then_chain will not work - # Also, Do NOT change the param name target_promise without changing - # those procs. - # Oh what a hack to get around lack of closures. Alternative would have - # been to pass an additional parameter (target_promise) - # to the application code but then that script would have had to - # carry that around. - - if {[info level] != 1} { - error "Internal error: _then_reaction not at level 1" - } - - if {[llength $cmd] == 0} { - switch -exact -- $status { - FULFILLED { $target_promise fulfill $value } - REJECTED { $target_promise reject $value $edict} - CHAINED - - PENDING - - default { - $target_promise reject "Internal error: invalid status $state" - } - } - } else { - # Invoke the real reaction code and fulfill/reject the target promise. - # Note the reaction code may have called one of the promise::then_* - # commands itself and reactions run resulting in the object being - # freed. Hence resolve using the safe* variants - # TBD - ideally we would like to execute at global level. However - # the then_* commands retrieve target_promise from level 1 (here) - # which they cannot if uplevel #0 is done. So directly invoke. - if {$status eq "REJECTED"} { - lappend cmd $value $edict - } else { - lappend cmd $value - } - if {[catch $cmd reaction_value reaction_edict]} { - safe_reject $target_promise $reaction_value $reaction_edict - } else { - safe_fulfill $target_promise $reaction_value - } - } - return -} - -proc promise::_cleanup_reaction {target_promise cleaner state value {edict {}}} { - # Run the specified cleaner and fulfill/reject the target promise - # accordingly. If the cleaner executes without error, the original - # value and state is passed on. If the cleaner executes with error - # the promise is rejected. - - if {[llength $cleaner] == 0} { - switch -exact -- $state { - FULFILLED { $target_promise fulfill $value } - REJECTED { $target_promise reject $value $edict } - CHAINED - - PENDING - - default { - $target_promise reject "Internal error: invalid state $state" - } - } - } else { - if {[catch {uplevel #0 $cleaner} err edict]} { - # Cleaner failed. Reject the target promise - $target_promise reject $err $edict - } else { - # Cleaner completed without errors, pass on the original value - if {$state eq "FULFILLED"} { - $target_promise fulfill $value - } else { - $target_promise reject $value $edict - } - } - } - return -} - -proc promise::then_fulfill {value} { - # Fulfills the promise returned by a [then] method call from - # within its reaction. - # value - the value with which to fulfill the promise - # - # The [Promise.then] method is a mechanism to chain asynchronous - # reactions by registering them on a promise. It returns a new - # promise which is settled by the return value from the reaction, - # or by the reaction calling one of three commands - 'then_fulfill', - # [then_reject] or [then_chain]. Calling 'then_fulfill' fulfills - # the promise returned by the 'then' method that queued the currently - # running reaction. - # - # It is an error to call this command from outside a reaction - # that was queued via the [then] method on a promise. - - # TBD - what if someone calls this from within a uplevel #0 ? The - # upvar will be all wrong - upvar #1 target_promise target_promise - if {![info exists target_promise]} { - set msg "promise::then_fulfill called in invalid context." - throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg - } - $target_promise fulfill $value -} - -proc promise::then_chain {promise} { - # Chains the promise returned by a [then] method call to - # another promise. - # promise - the promise to which the promise returned by [then] is - # to be chained - # - # The [Promise.then] method is a mechanism to chain asynchronous - # reactions by registering them on a promise. It returns a new - # promise which is settled by the return value from the reaction, - # or by the reaction calling one of three commands - [then_fulfill], - # 'then_reject' or [then_chain]. Calling 'then_chain' chains - # the promise returned by the 'then' method that queued the currently - # running reaction to $promise so that the former will be settled - # based on the latter. - # - # It is an error to call this command from outside a reaction - # that was queued via the [then] method on a promise. - upvar #1 target_promise target_promise - if {![info exists target_promise]} { - set msg "promise::then_chain called in invalid context." - throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg - } - $target_promise chain $promise -} - -proc promise::then_reject {reason edict} { - # Rejects the promise returned by a [then] method call from - # within its reaction. - # reason - a message string describing the reason for the rejection. - # edict - a Tcl error dictionary - # The [Promise.then] method is a mechanism to chain asynchronous - # reactions by registering them on a promise. It returns a new - # promise which is settled by the return value from the reaction, - # or by the reaction calling one of three commands - [then_fulfill], - # 'then_reject' or [then_chain]. Calling 'then_reject' rejects - # the promise returned by the 'then' method that queued the currently - # running reaction. - # - # It is an error to call this command from outside a reaction - # that was queued via the [then] method on a promise. - upvar #1 target_promise target_promise - if {![info exists target_promise]} { - set msg "promise::then_reject called in invalid context." - throw [list PROMISE THEN FULFILL NOTARGET $msg] $msg - } - $target_promise reject $reason $edict -} - -proc promise::all {promises} { - # Returns a promise that fulfills or rejects when all promises - # in the $promises argument have fulfilled or any one has rejected. - # promises - a list of Promise objects - # If any of $promises rejects, then the promise returned by the - # command will reject with the same value. Otherwise, the promise - # will fulfill when all promises have fulfilled. - # The resolved value will be a list of the resolved - # values of the contained promises. - - set all_promise [Promise new [lambda {promises prom} { - set npromises [llength $promises] - if {$npromises == 0} { - $prom fulfill {} - return - } - - # Ask each promise to update us when resolved. - foreach promise $promises { - $promise done \ - [list ::promise::_all_helper $prom $promise FULFILLED] \ - [list ::promise::_all_helper $prom $promise REJECTED] - } - - # We keep track of state with a dictionary that will be - # stored in $prom with the following keys: - # PROMISES - the list of promises in the order passed - # PENDING_COUNT - count of unresolved promises - # RESULTS - dictionary keyed by promise and containing resolved value - set all_state [list PROMISES $promises PENDING_COUNT $npromises RESULTS {}] - - $prom setdata ALLPROMISES $all_state - } $promises]] - - return $all_promise -} - -proc promise::all* args { - # Returns a promise that fulfills or rejects when all promises - # in the $args argument have fulfilled or any one has rejected. - # args - list of Promise objects - # This command is identical to the all command except that it takes - # multiple arguments, each of which is a Promise object. See [all] - # for a description. - return [all $args] -} - -# Callback for promise::all. -# all_promise - the "master" promise returned by the all call. -# done_promise - the promise whose callback is being serviced. -# resolution - whether the current promise was resolved with "FULFILLED" -# or "REJECTED" -# value - the value of the currently fulfilled promise or error description -# in case rejected -# edict - error dictionary (if promise was rejected) -proc promise::_all_helper {all_promise done_promise resolution value {edict {}}} { - if {![info object isa object $all_promise]} { - # The object has been deleted. Naught to do - return - } - if {[$all_promise state] ne "PENDING"} { - # Already settled. This can happen when a tracked promise is - # rejected and another tracked promise gets settled afterwards. - return - } - if {$resolution eq "REJECTED"} { - # This promise failed. Immediately reject the master promise - # TBD - can we somehow indicate which promise failed ? - $all_promise reject $value $edict - return - } - - # Update the state of the resolved tracked promise - set all_state [$all_promise getdata ALLPROMISES] - dict set all_state RESULTS $done_promise $value - dict incr all_state PENDING_COUNT -1 - $all_promise setdata ALLPROMISES $all_state - - # If all promises resolved, resolve the all promise - if {[dict get $all_state PENDING_COUNT] == 0} { - set values {} - foreach prom [dict get $all_state PROMISES] { - lappend values [dict get $all_state RESULTS $prom] - } - $all_promise fulfill $values - } - return -} - -proc promise::race {promises} { - # Returns a promise that fulfills or rejects when any promise - # in the $promises argument is fulfilled or rejected. - # promises - a list of Promise objects - # The returned promise will fulfill and reject with the same value - # as the first promise in $promises that fulfills or rejects. - set race_promise [Promise new [lambda {promises prom} { - if {[llength $promises] == 0} { - catch {throw {PROMISE RACE EMPTYSET} "No promises specified."} reason edict - $prom reject $reason $edict - return - } - # Use safe_*, do not directly call methods since $prom may be - # gc'ed once settled - foreach promise $promises { - $promise done [list ::promise::safe_fulfill $prom ] [list ::promise::safe_reject $prom] - } - } $promises]] - - return $race_promise -} - -proc promise::race* {args} { - # Returns a promise that fulfills or rejects when any promise - # in the passed arguments is fulfilled or rejected. - # args - list of Promise objects - # This command is identical to the 'race' command except that it takes - # multiple arguments, each of which is a Promise object. See [race] - # for a description. - return [race $args] -} - -proc promise::await {prom} { - # Waits for a promise to be settled and returns its resolved value. - # prom - the promise that is to be waited on - # This command may only be used from within a procedure constructed - # with the [async] command or any code invoked from it. - # - # Returns the resolved value of $prom if it is fulfilled or raises an error - # if it is rejected. - set coro [info coroutine] - if {$coro eq ""} { - throw {PROMISE AWAIT NOTCORO} "await called from outside a coroutine" - } - $prom done [list $coro success] [list $coro fail] - lassign [yieldto return -level 0] status val ropts - if {$status eq "success"} { - return $val - } else { - return -options $ropts $val - } -} - -proc promise::async {name paramdefs body} { - # Defines an procedure that will run a script asynchronously as a coroutine. - # name - name of the procedure - # paramdefs - the parameter definitions to the procedure in the same - # form as passed to the standard 'proc' command - # body - the script to be executed - # - # When the defined procedure $name is called, it runs the supplied $body - # within a new coroutine. The return value from the $name procedure call - # will be a promise that will be fulfilled when the coroutine completes - # normally or rejected if it completes with an error. - # - # Note that the passed $body argument is not the body of the - # the procedure $name. Rather it is run as an anonymous procedure in - # the coroutine but in the same namespace context as $name. Thus the - # caller or the $body script must not make any assumptions about - # relative stack levels, use of 'uplevel' etc. - # - # The primary purpose of this command is to make it easy, in - # conjunction with the [await] command, to wrap a sequence of asynchronous - # operations as a single computational unit. - # - # Returns a promise that will be settled with the result of the script. - if {![string equal -length 2 "$name" "::"]} { - set ns [uplevel 1 namespace current] - set name ${ns}::$name - } else { - set ns :: - } - set tmpl { - proc %NAME% {%PARAMDEFS%} { - set p [promise::Promise new [promise::lambda {real_args prom} { - coroutine ::promise::async#[info cmdcount] {*}[promise::lambda {p args} { - upvar #1 _current_async_promise current_p - set current_p $p - set status [catch [list apply [list {%PARAMDEFS%} {%BODY%} %NS%] {*}$args] res ropts] - if {$status == 0} { - $p fulfill $res - } else { - $p reject $res $ropts - } - } $prom {*}$real_args] - } [lrange [info level 0] 1 end]]] - return $p - } - } - eval [string map [list %NAME% $name \ - %PARAMDEFS% $paramdefs \ - %BODY% $body \ - %NS% $ns] $tmpl] -} - -proc promise::async_fulfill {val} { - # Fulfills a promise for an async procedure with the specified value. - # val - the value with which to fulfill the promise - # This command must only be called with the context of an [async] - # procedure. - # - # Returns an empty string. - upvar #1 _current_async_promise current_p - if {![info exists current_p]} { - error "async_fulfill called from outside an async context." - } - $current_p fulfill $val - return -} - -proc promise::async_reject {val {edict {}}} { - # Rejects a promise for an async procedure with the specified value. - # val - the value with which to reject the promise - # edict - error dictionary for rejection - # This command must only be called with the context of an [async] - # procedure. - # - # Returns an empty string. - upvar #1 _current_async_promise current_p - if {![info exists current_p]} { - error "async_reject called from outside an async context." - } - $current_p reject $val $edict - return -} - -proc promise::async_chain {prom} { - # Chains a promise for an async procedure to the specified promise. - # prom - the promise to which the async promise is to be linked. - # This command must only be called with the context of an [async] - # procedure. - # - # Returns an empty string. - upvar #1 _current_async_promise current_p - if {![info exists current_p]} { - error "async_chain called from outside an async context." - } - $current_p chain $prom - return -} - -proc promise::pfulfilled {value} { - # Returns a new promise that is already fulfilled with the specified value. - # value - the value with which to fulfill the created promise - return [Promise new [lambda {value prom} { - $prom fulfill $value - } $value]] -} - -proc promise::prejected {value {edict {}}} { - # Returns a new promise that is already rejected. - # value - the value with which to reject the promise - # edict - error dictionary for rejection - # By convention, $value should be of the format returned by - # [rejection]. - return [Promise new [lambda {value edict prom} { - $prom reject $value $edict - } $value $edict]] -} - -proc promise::eventloop {prom} { - # Waits in the eventloop until the specified promise is settled. - # prom - the promise to be waited on - # The command enters the event loop in similar fashion to the - # Tcl [vwait] command except that instead of waiting on a variable - # the command waits for the specified promise to be settled. As such - # it has the same caveats as the vwait command in terms of care - # being taken in nested calls etc. - # - # The primary use of the command is at the top level of a script - # to wait for one or more promise based tasks to be completed. Again, - # similar to the vwait forever idiom. - # - # - # Returns the resolved value of $prom if it is fulfilled or raises an error - # if it is rejected. - - set varname [namespace current]::_pwait_[info cmdcount] - $prom done \ - [lambda {varname result} { - set $varname [list success $result] - } $varname] \ - [lambda {varname error ropts} { - set $varname [list fail $error $ropts] - } $varname] - vwait $varname - lassign [set $varname] status result ropts - if {$status eq "success"} { - return $result - } else { - return -options $ropts $result - } -} - -proc promise::pgeturl {url args} { - # Returns a promise that will be fulfilled when the a URL is fetched. - # url - the URL to fetch - # args - arguments to pass to the [http::geturl] command - # This command invokes the asynchronous form of the [http::geturl] command - # of the 'http' package. If the operation completes with a status of - # 'ok', the returned promise is fulfilled with the contents of the - # http state array (see the documentation of [http::geturl]). If the - # the status is anything else, the promise is rejected with - # the 'reason' parameter to the reaction containing the error message - # and the 'edict' parameter containing the Tcl error dictionary - # with an additional key 'http_state', containing the - # contents of the http state array. - - uplevel #0 {package require http} - proc pgeturl {url args} { - set prom [Promise new [lambda {http_args prom} { - http::geturl {*}$http_args -command [promise::lambda {prom tok} { - upvar #0 $tok http_state - if {$http_state(status) eq "ok"} { - $prom fulfill [array get http_state] - } else { - if {[info exists http_state(error)]} { - set msg [lindex $http_state(error) 0] - } - if {![info exists msg] || $msg eq ""} { - set msg "Error retrieving URL." - } - catch {throw {PROMISE PGETURL} $msg} msg edict - dict set edict http_state [array get http_state] - $prom reject $msg $edict - } - http::cleanup $tok - } $prom] - } [linsert $args 0 $url]]] - return $prom - } - tailcall pgeturl $url {*}$args -} - -proc promise::ptimer {millisecs {value "Timer expired."}} { - # Returns a promise that will be fulfilled when the specified time has - # elapsed. - # millisecs - time interval in milliseconds - # value - the value with which the promise is to be fulfilled - # In case of errors (e.g. if $milliseconds is not an integer), the - # promise is rejected with the 'reason' parameter set to an error - # message and the 'edict' parameter set to a Tcl error dictionary. - # - # Also see [ptimeout] which is similar but rejects the promise instead - # of fulfilling it. - - return [Promise new [lambda {millisecs value prom} { - if {![string is integer -strict $millisecs]} { - # We don't allow "idle", "cancel" etc. as an argument to after - throw {PROMISE TIMER INVALID} "Invalid timeout value \"$millisecs\"." - } - after $millisecs [list promise::safe_fulfill $prom $value] - } $millisecs $value]] -} - -proc promise::ptimeout {millisecs {value "Operation timed out."}} { - # Returns a promise that will be rejected when the specified time has - # elapsed. - # millisecs - time interval in milliseconds - # value - the value with which the promise is to be rejected - # In case of errors (e.g. if $milliseconds is not an integer), the - # promise is rejected with the 'reason' parameter set to $value - # and the 'edict' parameter set to a Tcl error dictionary. - # - # Also see [ptimer] which is similar but fulfills the promise instead - # of rejecting it. - - return [Promise new [lambda {millisecs value prom} { - if {![string is integer -strict $millisecs]} { - # We don't want to accept "idle", "cancel" etc. for after - throw {PROMISE TIMER INVALID} "Invalid timeout value \"$millisecs\"." - } - after $millisecs [::promise::lambda {prom msg} { - catch {throw {PROMISE TIMER EXPIRED} $msg} msg edict - ::promise::safe_reject $prom $msg $edict - } $prom $value] - } $millisecs $value]] -} - -proc promise::pconnect {args} { - # Returns a promise that will be fulfilled when the a socket connection - # is completed. - # args - arguments to be passed to the Tcl 'socket' command - # This is a wrapper for the async version of the Tcl 'socket' command. - # If the connection completes, the promise is fulfilled with the - # socket handle. - # In case of errors (e.g. if the address cannot be fulfilled), the - # promise is rejected with the 'reason' parameter containing the - # error message and the 'edict' parameter containing the Tcl error - # dictionary. - # - return [Promise new [lambda {so_args prom} { - set so [socket -async {*}$so_args] - fileevent $so writable [promise::lambda {prom so} { - fileevent $so writable {} - set err [chan configure $so -error] - if {$err eq ""} { - $prom fulfill $so - } else { - catch {throw {PROMISE PCONNECT FAIL} $err} err edict - $prom reject $err $edict - } - } $prom $so] - } $args]] -} - -proc promise::_read_channel {prom chan data} { - set newdata [read $chan] - if {[string length $newdata] || ![eof $chan]} { - append data $newdata - fileevent $chan readable [list [namespace current]::_read_channel $prom $chan $data] - return - } - - # EOF - set code [catch { - # Need to make the channel blocking else no error is returned - # on the close - fileevent $chan readable {} - fconfigure $chan -blocking 1 - close $chan - } result edict] - if {$code} { - safe_reject $prom $result $edict - } else { - safe_fulfill $prom $data - } -} - -proc promise::pexec {args} { - # Runs an external program and returns a promise for its output. - # args - program and its arguments as passed to the Tcl 'open' call - # for creating pipes - # If the program runs without errors, the promise is fulfilled by its - # standard output content. Otherwise - # promise is rejected. - # - # Returns a promise that will be settled by the result of the program - return [Promise new [lambda {open_args prom} { - set chan [open |$open_args r] - fconfigure $chan -blocking 0 - fileevent $chan readable [list promise::_read_channel $prom $chan ""] - } $args]] -} - -proc promise::safe_fulfill {prom value} { - # Fulfills the specified promise. - # prom - the [Promise] object to be fulfilled - # value - the fulfillment value - # This is a convenience command that checks if $prom still exists - # and if so fulfills it with $value. - # - # Returns 0 if the promise does not exist any more, else the return - # value from its [fulfill] method. - if {![info object isa object $prom]} { - # The object has been deleted. Naught to do - return 0 - } - return [$prom fulfill $value] -} - -proc promise::safe_reject {prom value {edict {}}} { - # Rejects the specified promise. - # prom - the [Promise] object to be fulfilled - # value - see [Promise.reject] - # edict - see [Promise.reject] - # This is a convenience command that checks if $prom still exists - # and if so rejects it with the specified arguments. - # - # Returns 0 if the promise does not exist any more, else the return - # value from its [reject] method. - if {![info object isa object $prom]} { - # The object has been deleted. Naught to do - return - } - $prom reject $value $edict -} - -proc promise::ptask {script} { - # Creates a new Tcl thread to run the specified script and returns - # a promise for the script results. - # script - script to run in the thread - # Returns a promise that will be settled by the result of the script - # - # The `ptask` command runs the specified script in a new Tcl - # thread. The promise returned from this command will be fulfilled - # with the result of the script if it completes - # successfully. Otherwise, the promise will be rejected with an - # with the 'reason' parameter containing the error message - # and the 'edict' parameter containing the Tcl error dictionary - # from the script failure. - # - # Note that $script is a standalone script in that it is executed - # in a new thread with a virgin Tcl interpreter. Any packages used - # by $script have to be explicitly loaded, variables defined in the - # the current interpreter will not be available in $script and so on. - # - # The command requires the Thread package to be loaded. - - uplevel #0 package require Thread - proc [namespace current]::ptask script { - return [Promise new [lambda {script prom} { - set thread_script [string map [list %PROM% $prom %TID% [thread::id] %SCRIPT% $script] { - set retcode [catch {%SCRIPT%} result edict] - if {$retcode == 0 || $retcode == 2} { - # ok or return - set response [list ::promise::safe_fulfill %PROM% $result] - } else { - set response [list ::promise::safe_reject %PROM% $result $edict] - } - thread::send -async %TID% $response - }] - thread::create $thread_script - } $script]] - } - tailcall [namespace current]::ptask $script -} - -proc promise::pworker {tpool script} { - # Runs a script in a worker thread from a thread pool and - # returns a promise for the same. - # tpool - thread pool identifier - # script - script to run in the worker thread - # Returns a promise that will be settled by the result of the script - # - # The Thread package allows creation of a thread pool with the - # 'tpool create' command. The `pworker` command runs the specified - # script in a worker thread from a thread pool. The promise - # returned from this command will be fulfilled with the result of - # the script if it completes successfully. - # Otherwise, the promise will be rejected with an - # with the 'reason' parameter containing the error message - # and the 'edict' parameter containing the Tcl error dictionary - # from the script failure. - # - # Note that $script is a standalone script in that it is executed - # in a new thread with a virgin Tcl interpreter. Any packages used - # by $script have to be explicitly loaded, variables defined in the - # the current interpreter will not be available in $script and so on. - - # No need for package require Thread since if tpool is passed to - # us, Thread must already be loaded - return [Promise new [lambda {tpool script prom} { - set thread_script [string map [list %PROM% $prom %TID% [thread::id] %SCRIPT% $script] { - set retcode [catch {%SCRIPT%} result edict] - if {$retcode == 0 || $retcode == 2} { - set response [list ::promise::safe_fulfill %PROM% $result] - } else { - set response [list ::promise::safe_reject %PROM% $result $edict] - } - thread::send -async %TID% $response - }] - tpool::post -detached -nowait $tpool $thread_script - } $tpool $script]] -} - -if {0} { - package require http - proc checkurl {url} { - set prom [promise::Promise new [promise::lambda {url prom} { - http::geturl $url -method HEAD -command [promise::lambda {prom tok} { - upvar #0 $tok http_state - $prom fulfill [list $http_state(url) $http_state(status)] - ::http::cleanup $tok - } $prom] - } $url]] - return $prom - } - - proc checkurls {urls} { - return [promise::all [lmap url $urls {checkurl $url}]] - } - - [promise::all [ - list [ - promise::ptask {expr 1+1} - ] [ - promise::ptask {expr 2+2} - ] - ]] done [promise::lambda val {puts [tcl::mathop::* {*}$val]}] -} - -package provide promise [promise::version] - -if {[info exists ::argv0] && - [file tail [info script]] eq [file tail $::argv0]} { - set filename [file tail [info script]] - if {[llength $::argv] == 0} { - puts "Usage: [file tail [info nameofexecutable]] $::argv0 dist|install|tm|version" - exit 1 - } - switch -glob -- [lindex $::argv 0] { - ver* { puts [promise::version] } - tm - - dist* { - if {[file extension $filename] ne ".tm"} { - set dir [file join [file dirname [info script]] .. build] - file mkdir $dir - file copy -force [info script] [file join $dir [file rootname $filename]-[promise::version].tm] - } else { - error "Cannot create distribution from a .tm file" - } - } - install { - set dir [file join [tcl::pkgconfig get libdir,runtime] tcl8 8.6] - if {[file extension $filename] eq ".tm"} { - # We already are a .tm with version number - set target $filename - } else { - set target [file rootname $filename]-[promise::version].tm - } - file copy -force [info script] [file join $dir $target] - } - default { - puts stderr "Unknown option/command \"[lindex $::argv 0]\"" - exit 1 - } - } -} Index: tsmf/test-server.tcl ================================================================== --- tsmf/test-server.tcl +++ tsmf/test-server.tcl @@ -3,13 +3,10 @@ set workdir [file dirname [info script]] # For TSMF lappend auto_path [file join $workdir lib] -# For the Promise package -lappend auto_path [file join $workdir test-lib] - # For the TUAPI package lappend auto_path [file join $workdir ..] package require tsmf