This file is indexed.

/usr/share/tcltk/tcllib1.19/defer/defer.tcl is in tcllib 1.19-dfsg-2.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

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