Check-in [5363d1d42a]
Overview
Comment:Merge in TSMF support
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 5363d1d42a88ffbd79ed74ae584202119cd77ab5
User & Date: rkeene on 2024-03-05 21:04:06
Other Links: manifest | tags
Context
2024-03-07
19:02
Remove unused code check-in: ce2a7d32dc user: rkeene tags: trunk
2024-03-05
21:04
Merge in TSMF support check-in: 5363d1d42a user: rkeene tags: trunk
21:01
Add initial TSMF control Closed-Leaf check-in: d157ac314d user: rkeene tags: feature/tsmf-client-server
20:44
Merge in bug fixes for TSMF check-in: 48f82833d5 user: rkeene tags: trunk
Changes

Modified .fossil-settings/ignore-glob from [06351b337f] to [21b43e9320].

1
2
3
4
5
6

1
2
3
4
5
6
7






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

Added tsmf/lib/tsmf/pkgIndex.tcl version [e2cb03db4e].


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

Added tsmf/lib/tsmf/tsmf.tcl version [0957ddcea6].































































































































































































































































































































































































































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
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 version [3db466f589].




















































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
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 version [54d9aa5b1c].



















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
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 version [1f4235fbfe].






































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
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 version [11af1c0460].




1
2
3
+
+
+
#! /usr/bin/env bash

touch /tmp/one-shot

Added tsmf/test-svc/system/test3.conf version [9050e58c9f].



1
2
+
+
oneshot true
desired_state started

Added tsmf/test-svc/test1 version [85431f1034].







1
2
3
4
5
6
+
+
+
+
+
+
#! /usr/bin/env bash

sleep 1
touch /tmp/foo

sleep 30 &

Added tsmf/test-svc/test1.conf version [f23aa914f7].



1
2
+
+
desired_state started
requires svc://test2

Added tsmf/test-svc/test2 version [ce2e425845].







1
2
3
4
5
6
+
+
+
+
+
+
#! /usr/bin/env bash

sleep 10
touch /tmp/bar
sleep 120 &
exit 0

Added tsmf/test-svc/test2.conf version [123b9b4dde].


1
+
desired_state started