Tcl Library Source Code

[vset VERSION 1]
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin defer n [vset VERSION]]
[keywords golang]
[keywords cleanup]
[copyright {2017, Roy Keene}]
[moddesc {Defered execution ala Go}]
[titledesc {Defered execution}]
[category  {Utility}]
[require Tcl 8.6]
[require defer [opt [vset VERSION]]]
[description]

The [cmd defer] commands allow a developer to schedule actions to happen
as part of the current variable scope terminating.  This is most useful
for dealing with cleanup activities.  Since the defered actions always
execute, and always execute in the reverse order from which the defer
statements themselves execute, the programmer can schedule the cleanup
of a resource (for example, a channel) as soon as that resource is
acquired.  Then, later if the procedure or lambda ends, either due to
an error, or an explicit return, the cleanup of that resource will
always occur.

[para]

[section {COMMANDS}]

[list_begin definitions]

[call [cmd "::defer::defer"] \
        [opt [arg command]] \
        [opt [arg arg1]] \
        [opt [arg arg2]] \
        [opt [arg argN...]]]

Defers execution of some code until the current variable scope
ends.  Each argument is concatencated together to form the script
to execute at deferal time.

Multiple defer statements may be used, they are executed in the order
of last-in, first-out.

[comment {
	Just like Go !
}]

The return value is an identifier which can be used later with 
[cmd defer::cancel]

[call [cmd "::defer::with"] \
	[arg variableList] [arg script]]

Defers execution of a script while copying the current value of some
variables, whose names specified in [arg variableList], into the script.
The script acts like a lambda but executes at the same level as the
[cmd defer::with]
call.

The return value is the same as
[cmd ::defer::defer]

[call [cmd ::defer::autowith] [arg script]]

The same as
[cmd ::defer::with] but uses all local variables in the variable list.

[call [cmd ::defer::cancel] \
    [opt [arg id...]]]

Cancels the execution of a defered action.  The [arg id] argument is the
identifier returned by
[cmd ::defer::defer],
[cmd ::defer::with], or
[cmd ::defer::autowith].

Any number of arguments may be supplied, and all of the IDs supplied
will be cancelled.

[list_end]

[section "EXAMPLES"]

[example {
	package require defer 1
	apply {{} {
		set fd [open /dev/null]
		defer::defer close $fd
	}}
}]

[section "REFERENCES"]

[list_begin enumerated]
[enum]
[list_end]

[section AUTHORS]
Roy Keene

[vset CATEGORY defer]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

#! /usr/bin/env tclsh

# Copyright (c) 2017 Roy Keene
# 
# Permission is hereby granted, free of charge, to any person obtaining a 
# copy of this software and associated documentation files (the "Software"), 
# to deal in the Software without restriction, including without limitation 
# the rights to use, copy, modify, merge, publish, distribute, sublicense, 
# and/or sell copies of the Software, and to permit persons to whom the 
# Software is furnished to do so, subject to the following conditions:
# 
# The above copyright notice and this permission notice shall be included in 
# all copies or substantial portions of the Software.
# 
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 
# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 
# DEALINGS IN THE SOFTWARE.

package require Tcl 8.6

namespace eval ::defer {
	namespace export defer

	variable idVar "<defer>\n<trace variable>"
}

proc ::defer::with {args} {
	if {[llength $args] == 1} {
		set varlist [list]
		set code [lindex $args 0]
	} elseif {[llength $args] == 2} {
		set varlist [lindex $args 0]
		set code [lindex $args 1]
	} else {
		return -code error "wrong # args: defer::with ?varlist? script"
	}

	if {[info level] == 1} {
		set global true
	} else {
		set global false
	}

	# We can't reliably handle cleanup from the global scope, don't let people
	# register ineffective handlers for now
	if {$global} {
		return -code error "defer may not be used from the global scope"
	}

	# Generate an ID to un-defer if requested
	set id [clock clicks]
	for {set i 0} {$i < 5} {incr i} {
		append id [expr rand()]
	}

	# If a list of variable names has been supplied, slurp up their values
	# and add the appropriate script to set those variables in the lambda
	## Generate a list of commands to create the variables
	foreach var $varlist {
		if {![uplevel 1 [list info exists $var]]} {
			continue
		}

		if {[uplevel 1 [list array exists $var]]} {
			set val [uplevel 1 [list array get $var]]
			lappend codeSetVars [list unset -nocomplain $var]
			lappend codeSetVars [list array set $var $val]
		} else {
			set val [uplevel 1 [list set $var]]
			lappend codeSetVars [list set $var $val]
		}
	}

	## Format the above commands in the structure of a Tcl command
	if {[info exists codeSetVars]} {
		set codeSetVars [join $codeSetVars "; "]
		set code "${codeSetVars}; ${code}"
	}

	## Unset the "args" variable, which is just an artifact of the lambda
	set code "# ${id}\nunset args; ${code}"

	# Register our interest in a variable to monitor for it to disappear

	uplevel 1 [list trace add variable $::defer::idVar unset [list apply [list args $code]]]

	return $id
}

proc ::defer::defer {args} {
	set code $args
	tailcall ::defer::with $code
}

proc ::defer::autowith {script} {
	tailcall ::defer::with [uplevel 1 {info vars}] $script
}

proc ::defer::cancel {args} {
	set idList $args

	set traces [uplevel 1 [list trace info variable $::defer::idVar]]

	foreach trace $traces {
		set action [lindex $trace 0]
		set code   [lindex $trace 1]

		foreach id $idList {
			if {[string match "*# $id*" $code]} {
				uplevel 1 [list trace remove variable $::defer::idVar $action $code]
			}
		}
	}
}

package provide defer 1

# defer.test - Copyright (c) 2017 Roy Keene
# -*- tcl -*-

# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

testsNeedTcl     8.6
testsNeedTcltest 2

testing {
	useLocal defer.tcl defer
}

# -------------------------------------------------------------------------

# Series 1: defer::defer
test defer-1.0 {defer::defer simple} -setup {
	set deferTest FAIL
} -body {
	apply {{} {
		defer::defer apply {{} {
			uplevel 2 {set deferTest PASS}
		}}
	}}

	set deferTest
} -cleanup {
	unset -nocomplain deferTest
} -result {PASS}

test defer-1.1 {defer::defer fd} -setup {
	set fd [file tempfile]
} -body {
	apply {{fd} {
		defer::defer close $fd
	}} $fd

	lsearch -exact [chan names] $fd
} -cleanup {
	catch {
		close $fd
	}
	unset fd
} -result {-1}

# Series 2: defer::with
test defer-2.0 {defer::with simple} -setup {
	set deferTest FAIL
} -body {
	apply {{} {
		set withCheck true
		defer::with withCheck {
			if {$withCheck} {
				uplevel 1 {set deferTest PASS}
			}
		}
	}}

	set deferTest
} -cleanup {
	unset -nocomplain deferTest
} -result {PASS}

test defer-2.1 {defer::with fd} -setup {
	set fd [file tempfile]
} -body {
	apply {{fd} {
		defer::with fd {
			close $fd
		}
	}} $fd

	lsearch -exact [chan names] $fd
} -cleanup {
	catch {
		close $fd
	}
	unset fd
} -result {-1}

# Series 3: defer::autowith
test defer-3.0 {defer::autowith simple} -setup {
	set deferTest FAIL
} -body {
	apply {{} {
		set autoWithCheck true

		defer::autowith {
			if {$autoWithCheck} {
				uplevel 1 {set deferTest PASS}
			}
		}
	}}

	set deferTest
} -cleanup {
	unset -nocomplain deferTest
} -result {PASS}

test defer-3.1 {defer::autowith fd} -setup {
	set fd [file tempfile]
} -body {
	apply {{fd} {
		defer::autowith {
			close $fd
		}
	}} $fd

	lsearch -exact [chan names] $fd
} -cleanup {
	catch {
		close $fd
	}
	unset fd
} -result {-1}

# Series 4: defer::cancel
test defer-4.0 {defer::cancel simple} -setup {
	set deferTest FAIL-1
} -body {
	apply {{} {
		set defId [defer::with "" {
			uplevel 1 {set deferTest FAIL-2}
		}]

		defer::with "" {
			uplevel 1 {set deferTest PASS}
		}

		defer::cancel $defId
	}}

	set deferTest
} -cleanup {
	unset -nocomplain deferTest
} -result {PASS}

# Series 5: Order is LIFO
test defer-5.0 {defer is LIFO} -setup {
	set deferTest "INVALID"
} -body {
	apply {{} {
		for {set i 0} {$i < 10} {incr i} {
			defer::defer uplevel 1 [list set deferTest "RESULT:$i"]
		}
	}}

	set deferTest
} -cleanup {
	unset -nocomplain deferTest
} -result {RESULT:0}

# Series 6: Usage checks
test defer-6.0 {defer::defer global fails} -body {
	defer::defer info patchlevel
} -returnCodes ERROR -result {defer may not be used from the global scope}

test defer-6.1 {defer::defer with no args works} -body {
	apply {{} {
		defer::defer

		return "PASS"
	}}
} -result {PASS}

test defer-6.2 {defer::with syntax too few args} -body {
	apply {{} {
		defer::with
	}}
} -returnCodes ERROR -match glob -result {wrong # args: *}

test defer-6.3 {defer::with syntax too many args} -body {
	apply {{} {
		defer::with [list] error BADARG
	}}
} -returnCodes ERROR -match glob -result {wrong # args: *}

test defer-6.4 {defer::autowith syntax too few args} -body {
	apply {{} {
		defer::autowith
	}}
} -returnCodes ERROR -match glob -result {wrong # args: *}

test defer-6.5 {defer::autowith syntax too many args} -body {
	apply {{} {
		defer::autowith error BADARG
	}}
} -returnCodes ERROR -match glob -result {wrong # args: *}

test defer-6.6 {defer::cancel syntax too few args} -body {
	apply {{} {
		defer::cancel

		return "PASS"
	}}
} -result {PASS}

test defer-6.7 {defer::cancel syntax too many args} -body {
	apply {{} {
		defer::cancel A B

		return "PASS"
	}}
} -result {PASS}

# -------------------------------------------------------------------------
testsuiteCleanup

if {![package vsatisfies [package provide Tcl] 8.6]} {
    # PRAGMA: returnok
    return
}
package ifneeded defer 1 [list source [file join $dir defer.tcl]]

Module  control      _tci _man  _null
Module  coroutine   _tcl _null  _null
Module  counter     _tcl  _man  _null
Module  crc         _tcl  _man  _null
Module  cron        _tcl  _man  _null
Module  csv         _tcl  _man _exa
Module  debug       _tcl _null  _null
Module  defer       _tcl  _man  _null
Module  des         _tcl  _man  _null
Module  dicttool    _tcl  _man  _null
Module  dns          _msg _man _exa
Module  docstrip    _tcl  _man  _null
Module  doctools     _doc _man _exa
Module  doctools2base _tcl _man _null
Module  doctools2idx  _tcl _man _null