Index: .fossil-settings/ignore-glob
==================================================================
--- .fossil-settings/ignore-glob
+++ .fossil-settings/ignore-glob
@@ -2,5 +2,6 @@
 libtuapi.a
 tuapi.o
 tuapi.tcl.h
 pkgIndex.tcl
 compile_commands.json
+tsmf/test-log

ADDED   tsmf/lib/tsmf/pkgIndex.tcl
Index: tsmf/lib/tsmf/pkgIndex.tcl
==================================================================
--- tsmf/lib/tsmf/pkgIndex.tcl
+++ tsmf/lib/tsmf/pkgIndex.tcl
@@ -0,0 +1,1 @@
+package ifneeded tsmf 0.1 [list source [file join $dir tsmf.tcl]]

ADDED   tsmf/lib/tsmf/tsmf.tcl
Index: tsmf/lib/tsmf/tsmf.tcl
==================================================================
--- tsmf/lib/tsmf/tsmf.tcl
+++ tsmf/lib/tsmf/tsmf.tcl
@@ -0,0 +1,670 @@
+#! /usr/bin/env tclsh
+
+package require tuapi
+package require Thread
+
+namespace eval ::tsmf {}
+namespace eval ::tsmf::server {}
+namespace eval ::tsmf::server::internal {}
+namespace eval ::tsmf::client {}
+namespace eval ::tsmf::_helper {}
+
+set ::tsmf::_default_config {
+	path /tmp/.tsmf.sock
+	svcdir /lib/svc
+	confdirs /etc/svc
+	logdir /var/log/svc
+}
+
+proc ::tsmf::_helper::getConfig {name config} {
+	set config [dict merge $::tsmf::_default_config $config]
+	return [dict get $config $name]
+}
+
+proc ::tsmf::_helper::serializeRequest {id command argInfo} {
+	set data [dict create id $id command $command args [binary encode base64 $argInfo]]
+	return $data
+}
+
+proc ::tsmf::_helper::deserializeRequest {data} {
+	set id [dict get $data id]
+	set command [dict get $data command]
+	set args [binary decode base64 [dict get $data args]]
+
+	return [dict create id $id command $command args $args]
+}
+
+proc ::tsmf::_helper::serializeResponse {id result} {
+	set data [dict create id $id result [binary encode base64 $result]]
+	return $data
+}
+
+proc ::tsmf::_helper::deserializeResponse {data} {
+	set id [dict get $data id]
+	set result [binary decode base64 [dict get $data result]]
+
+	return [dict create id $id result $result]
+}
+
+
+# Setup the service handler as "init"
+proc ::tsmf::server::init {{config {}}} {
+	set socketName [::tsmf::_helper::getConfig path $config]
+
+	file delete -force $socketName
+
+	::tuapi::syscall::socket_unix -server ::tsmf::server::accept $socketName
+
+	array set ::tsmf::server::svcs {}
+
+	::tsmf::server::scan $config
+	after 0 [list ::tsmf::server::poll $config]
+}
+
+proc ::tsmf::server::internal::start {svcname svcscript svclog options} {
+	set tid [thread::create]
+
+	thread::send -async $tid [list set ::auto_path $::auto_path]
+	thread::send -async $tid [list package require tuapi]
+	thread::send -async $tid [list apply {{svcname svcscript svclog options} {
+		set code [catch {
+			file mkdir [file dirname $svclog]
+
+			dict with options {
+				set pgid [::tuapi::syscall::tsmf_start_svc $svcname $svcscript $svclog $env $dir $umask $uid $gid $timeout]
+			}
+		} output options]
+
+		set result [list code $code output $output options $options]
+		if {[info exists pgid]} {
+			lappend result pgid $pgid
+		}
+
+		return -level 0 $result
+	}} $svcname $svcscript $svclog $options] ::tsmf::server::internal::_result($tid)
+
+	vwait ::tsmf::server::internal::_result($tid)
+	set result $::tsmf::server::internal::_result($tid)
+	unset ::tsmf::server::internal::_result($tid)
+
+	thread::release $tid
+
+	if {[dict get $result code] != 0} {
+		return -code [dict get $result code] -options [dict get $result options] [dict get $result output]
+	}
+
+	set pgid [dict get $result pgid]
+	return $pgid
+}
+
+proc ::tsmf::server::internal::log {svcname message} {
+	set svclog [dict get $::tsmf::server::svcs($svcname) svclog]
+
+	set timestamp [clock format [clock seconds] -format {%b %e %H:%M:%S}]
+
+	catch {
+		set fd [open $svclog a]
+		foreach line [split $message \n] {
+			puts $fd "\[ $timestamp $line \]"
+		}
+	}
+
+	catch {
+		close $fd
+	}
+}
+
+proc ::tsmf::server::internal::stop {svcname svcstate} {
+	log $svcname "Killing $svcname"
+
+	# Terminate the process group
+	catch {
+		set pgid [dict get $svcstate pgid]
+		::tuapi::syscall::kill -$pgid 9
+	}
+}
+
+proc ::tsmf::server::notify {} {
+	set ::tsmf::server::pollidx -1
+}
+
+proc ::tsmf::server::poll {config} {
+	# Every 100ms we check to see if we should be doing anything, but
+	# don't do anything except every 10 checks, this way we can be called
+	# notify without being in the stack
+	if {![info exists ::tsmf::server::pollidx]} {
+		set ::tsmf::server::pollidx -1
+	}
+	after 100 [list ::tsmf::server::poll $config]
+	incr ::tsmf::server::pollidx
+
+	if {($::tsmf::server::pollidx % 10) != 0} {
+		return
+	}
+
+	if {($::tsmf::server::pollidx % 300) == 0} {
+		# Scan for any new services
+		::tsmf::server::scan $config
+	}
+
+	foreach svcname [array names ::tsmf::server::svcs] {
+		set stateVar ::tsmf::server::svcs($svcname)
+		unset -nocomplain state
+		array set state [set $stateVar]
+
+		# Detect oneshot services
+		set oneshot false
+		if {[dict exists $state(options) oneshot] && [dict get $state(options) oneshot]} {
+			set oneshot true
+		}
+
+
+		# Skip services that are starting or stopping
+		if {$state(state) eq "starting" || $state(state) eq "stopping"} {
+			continue
+		}
+
+		# We may want to consider services that do want to be started
+		# as wanting to be stopped, if their dependencies are not met
+		set desired_state $state(desired_state)
+
+		# Ensure all the requirements are met
+		set dependencies [dict get $state(options) requires]
+		dict unset $stateVar down_deps
+		unset -nocomplain state(down_deps)
+		foreach dependency $dependencies {
+			set dependency_state [::tsmf::server::state $dependency]
+
+			if {$dependency_state eq "started"} {
+				continue
+			}
+
+			set desired_state stopped
+
+			if {$state(desired_state) ne "stopped"} {
+				dict lappend $stateVar down_deps $dependency
+				lappend state(down_deps) $dependency
+			}
+		}
+
+		# Check if the service is in the desired state
+		if {$desired_state eq $state(state)} {
+			unset -nocomplain state(reason)
+			set ::tsmf::server::svcs($svcname) [array get state]
+
+			# If the desired state is down, and we are down, we
+			# don't need to verify that
+			if {$desired_state eq "stopped"} {
+				continue
+			}
+
+			# We can't verify oneshot services
+			if {$oneshot} {
+				continue
+			}
+
+			# Verify that the service is still running
+			if {[catch {
+				::tuapi::syscall::kill -$state(pgid) 0
+			}]} {
+				::tsmf::server::internal::log $svcname "Service died unexpectedly"
+
+				set state(changed_time) [clock seconds]
+				set state(state) stopped
+				set state(reason) "Service died unexpectedly"
+				unset -nocomplain state(pgid)
+				set ::tsmf::server::svcs($svcname) [array get state]
+
+				::tsmf::server::notify
+			}
+
+			continue
+		}
+
+		if {$oneshot && $desired_state eq "stopped"} {
+			set state(reason) "Cannot stop one-shot service"
+			set ::tsmf::server::svcs($svcname) [array get state]
+			continue
+		}
+
+		# Enact the change the state of the service
+		unset -nocomplain state
+		dict set $stateVar locked true
+		dict set $stateVar changed_time [clock seconds]
+		dict unset $stateVar reason
+		dict unset $stateVar fail_time
+
+		switch -exact -- $desired_state {
+			started {
+				dict set $stateVar state starting
+
+				set svcscript [dict get [set $stateVar] svcscript]
+				set svclog [dict get [set $stateVar] svclog]
+				set options [dict get [set $stateVar] options]
+
+				if {[catch {
+					set pgid [::tsmf::server::internal::start $svcname $svcscript $svclog $options]
+				} msg]} {
+					::tsmf::server::internal::log $svcname "Service failed to start: $msg"
+
+					dict set $stateVar state stopped
+					dict set $stateVar reason $msg
+					dict set $stateVar fail_time [clock seconds]
+					dict unset $stateVar pgid
+				} else {
+					dict set $stateVar state started
+					dict set $stateVar pgid $pgid
+				}
+			}
+			stopped {
+				dict set $stateVar state stopping
+
+				if {[catch {
+					::tsmf::server::internal::stop $svcname [set $stateVar]
+				} msg]} {
+					::tsmf::server::internal::log $svcname "Service failed to stop: $msg"
+
+					dict set $stateVar state started
+					dict set $stateVar reason $msg
+					dict set $stateVar fail_time [clock seconds]
+				} else {
+					dict set $stateVar state stopped
+					dict unset $stateVar pgid
+				}
+			}
+		}
+
+		dict set $stateVar changed_time [clock seconds]
+		dict unset $stateVar locked
+		array set state [set $stateVar]
+
+		if {[info exists state(next_desired_state)]} {
+			dict set $stateVar desired_state $state(next_desired_state)
+			dict unset $stateVar next_desired_state
+
+			::tsmf::server::notify
+		}
+
+		if {$state(state) eq $desired_state} {
+			::tsmf::server::notify
+		}
+	}
+}
+
+proc ::tsmf::server::accept {sock uid gid pid} {
+	fconfigure $sock -blocking false -encoding utf-8 -buffering line
+
+	fileevent $sock readable [list apply {{sock uid gid pid} {
+		set data ""
+		catch {
+			set data [gets $sock]
+		}
+
+		if {$data eq "" && [eof $sock]} {
+			catch {
+				close $sock
+			}
+			return
+		}
+
+		if {$data eq ""} {
+			return
+		}
+
+		set dataDict [::tsmf::_helper::deserializeRequest $data]
+
+		dict with dataDict {
+			if {$command in {start stop status list_svcs}} {
+				set resultCode [catch {uplevel #0 [list ::tsmf::server::$command {*}$args]} output]
+			} else {
+				set resultCode 1
+				set output "Unknown command: $command"
+			}
+
+			catch {
+				puts $sock [::tsmf::_helper::serializeResponse $id [list code $resultCode output $output]]
+			}
+			catch {
+				flush $sock
+			}
+		}
+	}} $sock $uid $gid $pid]
+}
+
+# Scan for services
+proc ::tsmf::server::scan {config} {
+	set config_svcdir [::tsmf::_helper::getConfig svcdir $config]
+
+	set services [glob -tails -nocomplain -directory $config_svcdir -type f * */* */*/* */*/*/* */*/*/*/*]
+	foreach name $services {
+		if {[string match "*.*" $name]} {
+			continue
+		}
+
+		set svcname svc://$name
+		if {[info exists ::tsmf::server::svcs($svcname)]} {
+			continue
+		}
+		if {[info exists ::tsmf::server::svcs_ignore($svcname)]} {
+			continue
+		}
+
+		set svcscript [file join $config_svcdir $name]
+		set ignore [apply {{svcscript} {
+			set retval false
+			catch {
+				set fd [open $svcscript]
+				set script [read $fd]
+				if {[regexp -lineanchor {^#[[:space:]]*TSMF-IGNORE$} $script]} {
+					set retval true
+				}
+			}
+
+			catch {
+				close $fd
+			}
+
+			return $retval
+		}} $svcscript]
+
+		if {$ignore} {
+			set ::tsmf::server::svcs_ignore($svcname) true
+			continue
+		}
+
+		::tsmf::server::add $name $config
+	}
+}
+
+# Add a service to the service registry (stopped)
+proc ::tsmf::server::add {name config {manual_options {}}} {
+	set config_svcdir [::tsmf::_helper::getConfig svcdir $config]
+	set config_logdir [::tsmf::_helper::getConfig logdir $config]
+	set config_confdirs [::tsmf::_helper::getConfig confdirs $config]
+
+	set svcname svc://$name
+	set svcscript [file join $config_svcdir {*}[split $name /]]
+	set svclog [file join $config_logdir [join [split $name /] -].log]
+
+	# Load configuration
+	foreach option_confdir [list $config_svcdir {*}$config_confdirs] {
+		set option_conffile_base [file join $option_confdir {*}[split $name /]]
+
+		lappend option_files ${option_conffile_base}.conf
+
+		foreach option_conffile [lsort -dictionary [glob -nocomplain -type f ${option_conffile_base}.*.conf]] {
+			lappend option_files [file join $option_confdir $option_conffile]
+		}
+	}
+
+	# Default options
+	set options {
+		env {}
+		dir /
+		umask 022
+		uid 0
+		gid 0
+		timeout 60
+		requires {}
+	}
+
+	# Load config from the service script
+	unset -nocomplain option_data
+	set option_data [apply {{svcscript} {
+		set retval [dict create]
+		catch {
+			set fd [open $svcscript]
+			set script [read $fd]
+			foreach line [split $script \n] {
+				if {![regexp {^#[[:space:]]*TSMF: (.*)$} $line -> option_data]} {
+					continue
+				}
+
+				set retval [string trim $option_data]
+
+				break
+			}
+		}
+		catch {
+			close $fd
+		}
+
+		return $retval
+	}} $svcscript]
+	catch {
+		set options [dict merge $options $option_data]
+	}
+
+	# Load config files
+	foreach option_file $option_files {
+		if {[file exists $option_file]} {
+			unset -nocomplain fd option_data
+			catch {
+				set fd [open $option_file]
+				set option_data [read $fd]
+				set options [dict merge $options $option_data]
+			}
+			catch {
+				close $fd
+			}
+		}
+	}
+
+	# Apply manual options
+	set options [dict merge $options $manual_options]
+
+	# If the "ignore" option is set, ignore the service altogether
+	if {[dict exists $options ignore] && [dict get $options ignore]} {
+		set ::tsmf::server::svcs_ignore($svcname) true
+		return
+	}
+	unset -nocomplain ::tsmf::server::svcs_ignore($svcname)
+
+	set state {
+		state stopped
+		desired_state stopped
+	}
+
+	# If the desired state is specified in the options, use that
+	if {[dict exists $options desired_state]} {
+		dict set state desired_state [dict get $options desired_state]
+	}
+
+	# If the service has already been added, use the existing state
+	if {[info exists ::tsmf::server::svcs($svcname)]} {
+		set state $::tsmf::server::svcs($svcname)
+	}
+
+	dict set state svcname $svcname
+	dict set state svcscript $svcscript
+	dict set state svclog $svclog
+	dict set state options $options
+	dict set state changed_time [clock seconds]
+
+	set ::tsmf::server::svcs($svcname) $state
+
+	return $svcname
+}
+
+# Set desired state
+proc ::tsmf::server::setDesiredState {name desired_state} {
+	if {![info exists ::tsmf::server::svcs($name)]} {
+		return false
+	}
+
+	set stateInfo $::tsmf::server::svcs($name)
+
+	# If the service is locked (e.g., because it is starting or stopping)
+	# we must not change the desired state, instead we set the "next_desired_state"
+	if {[dict exists $stateInfo locked] && [dict get $stateInfo locked]} {
+		set property next_desired_state
+	} else {
+		set property desired_state
+	}
+
+	dict set stateInfo $property $desired_state
+	set ::tsmf::server::svcs($name) $stateInfo
+
+	if {$property eq "desired_state"} {
+		::tsmf::server::notify
+	}
+
+	return true
+}
+
+# Start a service
+proc ::tsmf::server::start {svcname {options {}}} {
+	return [::tsmf::server::setDesiredState $svcname started]
+}
+
+# Stop a service
+proc ::tsmf::server::stop {svcname} {
+	return [::tsmf::server::setDesiredState $svcname stopped]
+}
+
+# Get service status
+proc ::tsmf::server::status {svcname} {
+	if {[info exists ::tsmf::server::svcs($svcname)]} {
+		set state $::tsmf::server::svcs($svcname)
+	} else {
+		set state {}
+	}
+
+	return $state
+}
+
+proc ::tsmf::server::state {svcname} {
+	set stateInfo [::tsmf::server::status $svcname]
+
+	if {[dict exists $stateInfo state]} {
+		return [dict get $stateInfo state]
+	}
+
+	return unknown
+}
+
+# Wait for a service to reach a specified state
+proc ::tsmf::_helper::wait {impl svcname state {timeout -1}} {
+	set now [clock milliseconds]
+
+	if {$timeout != -1} {
+		set end [expr {$now + $timeout}]
+	}
+
+	set workvar ::tsmf::_helper::wait([clock clicks][expr {rand()}])
+	while true {
+		set found_state [::tsmf::${impl}::state $svcname]
+		if {$state eq $found_state} {
+			return true
+		}
+
+		set now [clock milliseconds]
+		if {$timeout != -1 && $now > $end} {
+			break
+		}
+
+		after 100 [list set $workvar 1]
+		vwait $workvar
+		unset -nocomplain $workvar
+	}
+
+	return false
+}
+
+proc ::tsmf::server::wait {svcname state {timeout -1}} {
+	return [::tsmf::_helper::wait server $svcname $state $timeout]
+}
+
+proc ::tsmf::client::wait {svcname state {timeout -1}} {
+	return [::tsmf::_helper::wait client $svcname $state $timeout]
+}
+
+# Get a list of known services
+proc ::tsmf::server::list_svcs {} {
+	array set retval {}
+	foreach {name stateInfo} [array get ::tsmf::server::svcs] {
+		set retval($name) [apply {{name stateInfo} {
+			dict with stateInfo {
+				set output [dict create state $state desired_state $desired_state changed_time $changed_time]
+			}
+
+			if {[info exists reason]} {
+				dict set output reason $reason
+			}
+
+			if {[info exists down_deps]} {
+				dict set output down_deps $down_deps
+			}
+
+
+			return -level 0 $output
+		}} $name $stateInfo]
+	}
+
+	return [array get retval]
+}
+
+proc ::tsmf::_helper::connect {} {
+	set fd [::tuapi::syscall::socket_unix [::tsmf::_helper::getConfig path {}]]
+	return $fd
+}
+
+proc ::tsmf::_helper::sendRequest {command args} {
+	set fd [::tsmf::_helper::connect]
+	set id "1"
+	set data [::tsmf::_helper::serializeRequest $id $command $args]
+	puts $fd $data
+	flush $fd
+
+	fileevent $fd readable [list apply {{fd} {
+		set data ""
+		catch {
+			set data [gets $fd]
+		}
+
+		if {$data eq "" && [eof $fd]} {
+			catch {
+				close $fd
+			}
+			return
+		}
+
+		if {$data eq ""} {
+			return
+		}
+
+		set dataDict [::tsmf::_helper::deserializeResponse $data]
+		set ::tsmf::_helper::result([dict get $dataDict id]) [dict get $dataDict result]
+	}} $fd]
+
+	vwait ::tsmf::_helper::result($id)
+
+	set code [dict get $::tsmf::_helper::result($id) code]
+	set output [dict get $::tsmf::_helper::result($id) output]
+
+	unset ::tsmf::_helper::result($id)
+
+	return -code $code $output
+}
+
+# Start a service
+proc ::tsmf::client::start {name {options {}}} {
+	return [::tsmf::_helper::sendRequest start $name $options]
+}
+
+# Stop a service
+proc ::tsmf::client::stop {svcname} {
+	return [::tsmf::_helper::sendRequest stop $svcname]
+}
+
+# Get service status
+proc ::tsmf::client::status {svcname} {
+	return [::tsmf::_helper::sendRequest status $svcname]
+}
+
+# Get a list of known services
+proc ::tsmf::client::list_svcs {} {
+	return [::tsmf::_helper::sendRequest list_svcs]
+}
+
+package provide tsmf 0.1

ADDED   tsmf/test-client.tcl
Index: tsmf/test-client.tcl
==================================================================
--- tsmf/test-client.tcl
+++ tsmf/test-client.tcl
@@ -0,0 +1,83 @@
+#! /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
+	foreach item $list {
+		set len [string length $item]
+		if {$len > $maxlen} {
+			set maxlen $len
+		}
+	}
+	return $maxlen
+}
+
+proc relTime {time} {
+	set now [clock seconds]
+	set delta [expr {$now - $time}]
+
+	set future " "
+	if {$delta < 0} {
+		set future "+"
+		set delta [expr {abs($delta)}]
+	}
+
+	set fmt1 "%b_%d"
+	set fmt2 "%H:%M:%S"
+	set now_fmt1 [clock format $now -format $fmt1]
+	set time_fmt [clock format $time -format $fmt1]
+
+	if {$now_fmt1 eq $time_fmt} {
+		set time_fmt [clock format $time -format $fmt2]
+	}
+
+	return ${future}$time_fmt
+}
+
+namespace eval ::cmd {}
+proc ::cmd::list {args} {
+	set info [::tsmf::client::list_svcs]
+
+	set statelen [expr {[maxlen {starting started stopping stopped}] + 1}]
+
+	set fmt "%-${statelen}s  %10s  %s"
+
+	puts [format $fmt "STATE" "STIME" "SVC"]
+	foreach {name svcInfo} $info {
+		set state [dict get $svcInfo state]
+		set desired_state [dict get $svcInfo desired_state]
+		set changed_time [dict get $svcInfo changed_time]
+		if {$state ne $desired_state} {
+			set state "${state}*"
+		}
+
+		puts [format $fmt $state [relTime $changed_time] $name]
+	}
+}
+
+proc ::cmd::start name {
+	::tsmf::client::start $name
+}
+
+proc ::cmd::stop name {
+	::tsmf::client::stop $name
+}
+
+proc ::cmd::info name {
+	set info [::tsmf::client::status $name]
+	puts $info
+}
+
+
+set mode "list"
+
+if {[llength $argv] > 0} {
+	set mode [lindex $argv 0]
+	set argv [lrange $argv 1 end]
+}
+
+::cmd::$mode $argv

ADDED   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
@@ -0,0 +1,1298 @@
+# 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
+        }
+    }
+}

ADDED   tsmf/test-server.tcl
Index: tsmf/test-server.tcl
==================================================================
--- tsmf/test-server.tcl
+++ tsmf/test-server.tcl
@@ -0,0 +1,37 @@
+#! /usr/bin/env tclsh
+
+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
+
+# Create a new log directory for this run
+set logdir [file join $workdir test-log]
+file delete -force $logdir
+file mkdir $logdir
+
+set svcdir [file join $workdir test-svc]
+
+# Initialize the TSMF server
+::tsmf::server::init [list \
+	svcdir [file join $workdir test-svc] \
+	confdirs [list [file join $workdir test-svc]] \
+	logdir $logdir \
+]
+puts "INIT complete"
+
+puts "Starting service..."
+set result [::tsmf::server::wait svc://test1 started]
+puts "OK! $result"
+
+puts "Initialization complete"
+
+vwait ::done

ADDED   tsmf/test-svc/system/test3
Index: tsmf/test-svc/system/test3
==================================================================
--- tsmf/test-svc/system/test3
+++ tsmf/test-svc/system/test3
@@ -0,0 +1,3 @@
+#! /usr/bin/env bash
+
+touch /tmp/one-shot

ADDED   tsmf/test-svc/system/test3.conf
Index: tsmf/test-svc/system/test3.conf
==================================================================
--- tsmf/test-svc/system/test3.conf
+++ tsmf/test-svc/system/test3.conf
@@ -0,0 +1,2 @@
+oneshot true
+desired_state started

ADDED   tsmf/test-svc/test1
Index: tsmf/test-svc/test1
==================================================================
--- tsmf/test-svc/test1
+++ tsmf/test-svc/test1
@@ -0,0 +1,6 @@
+#! /usr/bin/env bash
+
+sleep 1
+touch /tmp/foo
+
+sleep 30 &

ADDED   tsmf/test-svc/test1.conf
Index: tsmf/test-svc/test1.conf
==================================================================
--- tsmf/test-svc/test1.conf
+++ tsmf/test-svc/test1.conf
@@ -0,0 +1,2 @@
+desired_state started
+requires svc://test2

ADDED   tsmf/test-svc/test2
Index: tsmf/test-svc/test2
==================================================================
--- tsmf/test-svc/test2
+++ tsmf/test-svc/test2
@@ -0,0 +1,6 @@
+#! /usr/bin/env bash
+
+sleep 10
+touch /tmp/bar
+sleep 120 &
+exit 0

ADDED   tsmf/test-svc/test2.conf
Index: tsmf/test-svc/test2.conf
==================================================================
--- tsmf/test-svc/test2.conf
+++ tsmf/test-svc/test2.conf
@@ -0,0 +1,1 @@
+desired_state started