tuapi.so
libtuapi.a
tuapi.o
tuapi.tcl.h
pkgIndex.tcl
compile_commands.json
tsmf/test-log

package ifneeded tsmf 0.1 [list source [file join $dir tsmf.tcl]]

#! /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

#! /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

# 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
        }
    }
}