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