1#! /usr/bin/env tclsh
2
3# Copyright (c) 2017 Roy Keene
4#
5# Permission is hereby granted, free of charge, to any person obtaining a
6# copy of this software and associated documentation files (the "Software"),
7# to deal in the Software without restriction, including without limitation
8# the rights to use, copy, modify, merge, publish, distribute, sublicense,
9# and/or sell copies of the Software, and to permit persons to whom the
10# Software is furnished to do so, subject to the following conditions:
11#
12# The above copyright notice and this permission notice shall be included in
13# all copies or substantial portions of the Software.
14#
15# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
18# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
20# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
21# DEALINGS IN THE SOFTWARE.
22
23package require Tcl 8.6
24
25namespace eval ::defer {
26	namespace export defer
27
28	variable idVar "<defer>\n<trace variable>"
29}
30
31proc ::defer::with {args} {
32	if {[llength $args] == 1} {
33		set varlist [list]
34		set code [lindex $args 0]
35	} elseif {[llength $args] == 2} {
36		set varlist [lindex $args 0]
37		set code [lindex $args 1]
38	} else {
39		return -code error "wrong # args: defer::with ?varlist? script"
40	}
41
42	if {[info level] == 1} {
43		set global true
44	} else {
45		set global false
46	}
47
48	# We can't reliably handle cleanup from the global scope, don't let people
49	# register ineffective handlers for now
50	if {$global} {
51		return -code error "defer may not be used from the global scope"
52	}
53
54	# Generate an ID to un-defer if requested
55	set id [clock clicks]
56	for {set i 0} {$i < 5} {incr i} {
57		append id [expr rand()]
58	}
59
60	# If a list of variable names has been supplied, slurp up their values
61	# and add the appropriate script to set those variables in the lambda
62	## Generate a list of commands to create the variables
63	foreach var $varlist {
64		if {![uplevel 1 [list info exists $var]]} {
65			continue
66		}
67
68		if {[uplevel 1 [list array exists $var]]} {
69			set val [uplevel 1 [list array get $var]]
70			lappend codeSetVars [list unset -nocomplain $var]
71			lappend codeSetVars [list array set $var $val]
72		} else {
73			set val [uplevel 1 [list set $var]]
74			lappend codeSetVars [list set $var $val]
75		}
76	}
77
78	## Format the above commands in the structure of a Tcl command
79	if {[info exists codeSetVars]} {
80		set codeSetVars [join $codeSetVars "; "]
81		set code "${codeSetVars}; ${code}"
82	}
83
84	## Unset the "args" variable, which is just an artifact of the lambda
85	set code "# ${id}\nunset args; ${code}"
86
87	# Register our interest in a variable to monitor for it to disappear
88
89	uplevel 1 [list trace add variable $::defer::idVar unset [list apply [list args $code]]]
90
91	return $id
92}
93
94proc ::defer::defer {args} {
95	set code $args
96	tailcall ::defer::with $code
97}
98
99proc ::defer::autowith {script} {
100	tailcall ::defer::with [uplevel 1 {info vars}] $script
101}
102
103proc ::defer::cancel {args} {
104	set idList $args
105
106	set traces [uplevel 1 [list trace info variable $::defer::idVar]]
107
108	foreach trace $traces {
109		set action [lindex $trace 0]
110		set code   [lindex $trace 1]
111
112		foreach id $idList {
113			if {[string match "*# $id*" $code]} {
114				uplevel 1 [list trace remove variable $::defer::idVar $action $code]
115			}
116		}
117	}
118}
119
120package provide defer 1
121