/usr/share/tcltk/tcllib1.18/control/do.tcl is in tcllib 1.18-dfsg-3.
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 | # do.tcl --
#
# Tcl implementation of a "do ... while|until" loop.
#
# Originally written for the "Texas Tcl Shootout" programming contest
# at the 2000 Tcl Conference in Austin/Texas.
#
# Copyright (c) 2001 by Reinhard Max <Reinhard.Max@gmx.de>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: do.tcl,v 1.6 2004/01/15 06:36:12 andreas_kupries Exp $
#
namespace eval ::control {
proc do {body args} {
#
# Implements a "do body while|until test" loop
#
# It is almost as fast as builtin "while" command for loops with
# more than just a few iterations.
#
set len [llength $args]
if {$len !=2 && $len != 0} {
set proc [namespace current]::[lindex [info level 0] 0]
return -code error "wrong # args: should be \"$proc body\" or \"$proc body \[until|while\] test\""
}
set test 0
foreach {whileOrUntil test} $args {
switch -exact -- $whileOrUntil {
"while" {}
"until" { set test !($test) }
default {
return -code error \
"bad option \"$whileOrUntil\": must be until, or while"
}
}
break
}
# the first invocation of the body
set code [catch { uplevel 1 $body } result]
# decide what to do upon the return code:
#
# 0 - the body executed successfully
# 1 - the body raised an error
# 2 - the body invoked [return]
# 3 - the body invoked [break]
# 4 - the body invoked [continue]
# everything else - return and pass on the results
#
switch -exact -- $code {
0 {}
1 {
return -errorinfo [ErrorInfoAsCaller uplevel do] \
-errorcode $::errorCode -code error $result
}
3 {
# FRINK: nocheck
return
}
4 {}
default {
return -code $code $result
}
}
# the rest of the loop
set code [catch {uplevel 1 [list while $test $body]} result]
if {$code == 1} {
return -errorinfo [ErrorInfoAsCaller while do] \
-errorcode $::errorCode -code error $result
}
return -code $code $result
}
}
|