summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2024-06-13 09:51:00 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2024-06-13 09:51:00 (GMT)
commit0bcc000f423dd258c0f36b50a0c0d4c29148cf98 (patch)
treea565890ed749f3590c2ce13915c8603b3acecccb
parente01b46fbc55558df958c0847f942b249bddcf5b7 (diff)
parent0666949c281e23375ccedec80d383fb58ce60bd0 (diff)
downloadtcl-0bcc000f423dd258c0f36b50a0c0d4c29148cf98.zip
tcl-0bcc000f423dd258c0f36b50a0c0d4c29148cf98.tar.gz
tcl-0bcc000f423dd258c0f36b50a0c0d4c29148cf98.tar.bz2
Use tabs for indenting in stead of 8 spaces. Unbreak clang build
Diffstat
-rw-r--r--doc/configurable.n2
-rw-r--r--generic/tclCmdIL.c2
-rw-r--r--library/history.tcl2
-rw-r--r--library/http/http.tcl817
-rw-r--r--library/init.tcl10
-rw-r--r--library/msgcat/msgcat.tcl4
-rw-r--r--library/opt/optparse.tcl496
-rw-r--r--library/package.tcl20
-rw-r--r--library/platform/shell.tcl2
-rw-r--r--library/safe.tcl76
-rw-r--r--library/tcltest/tcltest.tcl158
-rw-r--r--tests/remote.tcl8
12 files changed, 798 insertions, 799 deletions
diff --git a/doc/configurable.n b/doc/configurable.n
index 7ab5b92..d2e6b18 100644
--- a/doc/configurable.n
+++ b/doc/configurable.n
@@ -1,5 +1,5 @@
'\"
-'\" Copyright © 2019 Donal K. Fellows
+'\" Copyright (c) 2019 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 5c20317..e2ea401 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -4070,10 +4070,10 @@ SequenceIdentifyArgument(
}
doExpr:
/* Check for an index expression */
- int keyword;
if (Tcl_ExprObj(interp, argPtr, &exprValueObj) != TCL_OK) {
return ErrArg;
}
+ int keyword;
/* Determine if result of expression is double or int */
if (Tcl_GetNumberFromObj(interp, exprValueObj, &internalPtr,
&keyword) != TCL_OK
diff --git a/library/history.tcl b/library/history.tcl
index ec59ac7..4c36bf0 100644
--- a/library/history.tcl
+++ b/library/history.tcl
@@ -197,7 +197,7 @@ proc ::tcl::HistInfo {{count {}}} {
if {![info exists history($i)]} {
continue
}
- set cmd [string map [list \n \n\t] [string trimright $history($i) \ \n]]
+ set cmd [string map [list \n \n\t] [string trimright $history($i) \ \n]]
append result $newline[format "%6d %s" $i $cmd]
set newline \n
}
diff --git a/library/http/http.tcl b/library/http/http.tcl
index 63c2403..54af38f 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -157,69 +157,69 @@ namespace eval http {
variable ThreadCounter 0
variable reasonDict [dict create {*}{
- 100 Continue
- 101 {Switching Protocols}
- 102 Processing
- 103 {Early Hints}
- 200 OK
- 201 Created
- 202 Accepted
- 203 {Non-Authoritative Information}
- 204 {No Content}
- 205 {Reset Content}
- 206 {Partial Content}
- 207 Multi-Status
- 208 {Already Reported}
- 226 {IM Used}
- 300 {Multiple Choices}
- 301 {Moved Permanently}
- 302 Found
- 303 {See Other}
- 304 {Not Modified}
- 305 {Use Proxy}
- 306 (Unused)
- 307 {Temporary Redirect}
- 308 {Permanent Redirect}
- 400 {Bad Request}
- 401 Unauthorized
- 402 {Payment Required}
- 403 Forbidden
- 404 {Not Found}
- 405 {Method Not Allowed}
- 406 {Not Acceptable}
- 407 {Proxy Authentication Required}
- 408 {Request Timeout}
- 409 Conflict
- 410 Gone
- 411 {Length Required}
- 412 {Precondition Failed}
- 413 {Content Too Large}
- 414 {URI Too Long}
- 415 {Unsupported Media Type}
- 416 {Range Not Satisfiable}
- 417 {Expectation Failed}
- 418 (Unused)
- 421 {Misdirected Request}
- 422 {Unprocessable Content}
- 423 Locked
- 424 {Failed Dependency}
- 425 {Too Early}
- 426 {Upgrade Required}
- 428 {Precondition Required}
- 429 {Too Many Requests}
- 431 {Request Header Fields Too Large}
- 451 {Unavailable For Legal Reasons}
- 500 {Internal Server Error}
- 501 {Not Implemented}
- 502 {Bad Gateway}
- 503 {Service Unavailable}
- 504 {Gateway Timeout}
- 505 {HTTP Version Not Supported}
- 506 {Variant Also Negotiates}
- 507 {Insufficient Storage}
- 508 {Loop Detected}
- 510 {Not Extended (OBSOLETED)}
- 511 {Network Authentication Required}
+ 100 Continue
+ 101 {Switching Protocols}
+ 102 Processing
+ 103 {Early Hints}
+ 200 OK
+ 201 Created
+ 202 Accepted
+ 203 {Non-Authoritative Information}
+ 204 {No Content}
+ 205 {Reset Content}
+ 206 {Partial Content}
+ 207 Multi-Status
+ 208 {Already Reported}
+ 226 {IM Used}
+ 300 {Multiple Choices}
+ 301 {Moved Permanently}
+ 302 Found
+ 303 {See Other}
+ 304 {Not Modified}
+ 305 {Use Proxy}
+ 306 (Unused)
+ 307 {Temporary Redirect}
+ 308 {Permanent Redirect}
+ 400 {Bad Request}
+ 401 Unauthorized
+ 402 {Payment Required}
+ 403 Forbidden
+ 404 {Not Found}
+ 405 {Method Not Allowed}
+ 406 {Not Acceptable}
+ 407 {Proxy Authentication Required}
+ 408 {Request Timeout}
+ 409 Conflict
+ 410 Gone
+ 411 {Length Required}
+ 412 {Precondition Failed}
+ 413 {Content Too Large}
+ 414 {URI Too Long}
+ 415 {Unsupported Media Type}
+ 416 {Range Not Satisfiable}
+ 417 {Expectation Failed}
+ 418 (Unused)
+ 421 {Misdirected Request}
+ 422 {Unprocessable Content}
+ 423 Locked
+ 424 {Failed Dependency}
+ 425 {Too Early}
+ 426 {Upgrade Required}
+ 428 {Precondition Required}
+ 429 {Too Many Requests}
+ 431 {Request Header Fields Too Large}
+ 451 {Unavailable For Legal Reasons}
+ 500 {Internal Server Error}
+ 501 {Not Implemented}
+ 502 {Bad Gateway}
+ 503 {Service Unavailable}
+ 504 {Gateway Timeout}
+ 505 {HTTP Version Not Supported}
+ 506 {Variant Also Negotiates}
+ 507 {Insufficient Storage}
+ 508 {Loop Detected}
+ 510 {Not Extended (OBSOLETED)}
+ 511 {Network Authentication Required}
}]
variable failedProxyValues {
@@ -299,7 +299,7 @@ proc http::register {proto port command {socketCmdVarName {}} {useSockThread 0}
variable urlTypes
set lower [string tolower $proto]
if {[info exists urlTypes($lower)]} {
- unregister $lower
+ unregister $lower
}
set urlTypes($lower) [list $port $command $socketCmdVarName $useSockThread $endToEndProxy]
@@ -347,7 +347,7 @@ proc http::unregister {proto} {
# Arguments:
# args Options parsed by the procedure.
# Results:
-# TODO
+# TODO
proc http::config {args} {
variable http
@@ -401,13 +401,13 @@ proc http::config {args} {
proc http::reasonPhrase {code} {
variable reasonDict
if {![regexp -- {^[1-5][0-9][0-9]$} $code]} {
- set msg {argument must be a three-digit integer from 100 to 599}
- return -code error $msg
+ set msg {argument must be a three-digit integer from 100 to 599}
+ return -code error $msg
}
if {[dict exists $reasonDict $code]} {
- set reason [dict get $reasonDict $code]
+ set reason [dict get $reasonDict $code]
} else {
- set reason Unassigned
+ set reason Unassigned
}
return $reason
}
@@ -425,7 +425,7 @@ proc http::reasonPhrase {code} {
# reported to two places.
#
# Side Effects:
-# May close the socket.
+# May close the socket.
proc http::Finish {token {errormsg ""} {skipCB 0}} {
variable socketMapping
@@ -454,9 +454,9 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
rename ${token}--SocketCoroutine {}
}
if {[info exists state(socketcoro)]} {
- Log $token Cancel socket after-idle event (Finish)
- after cancel $state(socketcoro)
- unset state(socketcoro)
+ Log $token Cancel socket after-idle event (Finish)
+ after cancel $state(socketcoro)
+ unset state(socketcoro)
}
# Is this an upgrade request/response?
@@ -481,14 +481,14 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
set sock $state(sock)
CloseSocket $state(sock) $token
} else {
- # When opening the socket and calling http::reset
- # immediately, the socket may not yet exist.
- # Test http-4.11 may come here.
+ # When opening the socket and calling http::reset
+ # immediately, the socket may not yet exist.
+ # Test http-4.11 may come here.
}
if {$state(tid) ne {}} {
- # When opening the socket in a thread, and calling http::reset
- # immediately, the thread may still exist.
- # Test http-4.11 may come here.
+ # When opening the socket in a thread, and calling http::reset
+ # immediately, the thread may still exist.
+ # Test http-4.11 may come here.
thread::release $state(tid)
set state(tid) {}
} else {
@@ -503,9 +503,8 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
# PASSED TO http::geturl AS -command callback.
catch {fileevent $state(sock) readable {}}
catch {fileevent $state(sock) writable {}}
- } elseif {
- ([info exists state(-keepalive)] && !$state(-keepalive))
- || ([info exists state(connection)] && ("close" in $state(connection)))
+ } elseif {([info exists state(-keepalive)] && !$state(-keepalive))
+ || ([info exists state(connection)] && ("close" in $state(connection)))
} {
set closeQueue 1
set connId $state(socketinfo)
@@ -513,9 +512,9 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
set sock $state(sock)
CloseSocket $state(sock) $token
} else {
- # When opening the socket and calling http::reset
- # immediately, the socket may not yet exist.
- # Test http-4.11 may come here.
+ # When opening the socket and calling http::reset
+ # immediately, the socket may not yet exist.
+ # Test http-4.11 may come here.
}
} elseif {
([info exists state(-keepalive)] && $state(-keepalive))
@@ -921,7 +920,7 @@ proc http::Unset {connId} {
# why Status info.
#
# Side Effects:
-# See Finish
+# See Finish
proc http::reset {token {why reset}} {
variable $token
@@ -1120,7 +1119,7 @@ proc http::CreateToken {url args} {
if {[regexp -- $pat $flag]} {
# Validate numbers
if { [info exists type($flag)]
- && (![string is $type($flag) -strict $value])
+ && (![string is $type($flag) -strict $value])
} {
unset $token
return -code error \
@@ -1404,9 +1403,9 @@ proc http::CreateToken {url args} {
}
if {$useSockThread} {
- set targs [list -type $token]
+ set targs [list -type $token]
} else {
- set targs {}
+ set targs {}
}
set state(connArgs) [list $proto $phost $srvurl]
set state(openCmd) [list {*}$defcmd {*}$sockopts {*}$targs {*}$targetAddr]
@@ -1507,8 +1506,8 @@ proc http::CreateToken {url args} {
unset reusing
if {![info exists sock]} {
- # N.B. At this point ([info exists sock] == $state(reusing)).
- # This will no longer be true after we set a value of sock here.
+ # N.B. At this point ([info exists sock] == $state(reusing)).
+ # This will no longer be true after we set a value of sock here.
# Give the socket a placeholder name.
set sock HTTP_PLACEHOLDER_[incr TmpSockCounter]
}
@@ -1605,34 +1604,34 @@ proc http::AsyncTransaction {token} {
# This code is executed only for the first -keepalive request on a
# socket. It makes the socket persistent.
##Log " PreparePersistentConnection" $token -- $sock -- DO
- set DoLater [PreparePersistentConnection $token]
+ set DoLater [PreparePersistentConnection $token]
} else {
- ##Log " PreparePersistentConnection" $token -- $sock -- SKIP
- set DoLater {-traceread 0 -tracewrite 0}
+ ##Log " PreparePersistentConnection" $token -- $sock -- SKIP
+ set DoLater {-traceread 0 -tracewrite 0}
}
if {$state(ReusingPlaceholder)} {
- # - This request was added to the socketPhQueue of a persistent
- # connection.
- # - But the connection has not yet been created and is a placeholder;
- # - And the placeholder was created by an earlier request.
- # - When that earlier request calls OpenSocket, its placeholder is
- # replaced with a true socket, and it then executes the equivalent of
- # OpenSocket for any subsequent requests that have
- # $state(ReusingPlaceholder).
- Log >J$tk after idle coro NO - ReusingPlaceholder
+ # - This request was added to the socketPhQueue of a persistent
+ # connection.
+ # - But the connection has not yet been created and is a placeholder;
+ # - And the placeholder was created by an earlier request.
+ # - When that earlier request calls OpenSocket, its placeholder is
+ # replaced with a true socket, and it then executes the equivalent of
+ # OpenSocket for any subsequent requests that have
+ # $state(ReusingPlaceholder).
+ Log >J$tk after idle coro NO - ReusingPlaceholder
} elseif {$state(alreadyQueued)} {
- # - This request was added to the socketWrQueue and socketPlayCmd
- # of a persistent connection that will close at the end of its current
- # read operation.
- Log >J$tk after idle coro NO - alreadyQueued
+ # - This request was added to the socketWrQueue and socketPlayCmd
+ # of a persistent connection that will close at the end of its current
+ # read operation.
+ Log >J$tk after idle coro NO - alreadyQueued
} else {
- Log >J$tk after idle coro YES
- set CoroName ${token}--SocketCoroutine
- set cancel [after idle [list coroutine $CoroName ::http::OpenSocket \
- $token $DoLater]]
- dict set socketCoEvent($state(socketinfo)) $token $cancel
- set state(socketcoro) $cancel
+ Log >J$tk after idle coro YES
+ set CoroName ${token}--SocketCoroutine
+ set cancel [after idle [list coroutine $CoroName ::http::OpenSocket \
+ $token $DoLater]]
+ dict set socketCoEvent($state(socketinfo)) $token $cancel
+ set state(socketcoro) $cancel
}
return
@@ -1677,36 +1676,36 @@ proc http::PreparePersistentConnection {token} {
# no other tokens whose (proxyUsed) must be modified.
if {![info exists socketRdState($state(socketinfo))]} {
- set socketRdState($state(socketinfo)) {}
- # set varName ::http::socketRdState($state(socketinfo))
- # trace add variable $varName unset ::http::CancelReadPipeline
- dict set DoLater -traceread 1
+ set socketRdState($state(socketinfo)) {}
+ # set varName ::http::socketRdState($state(socketinfo))
+ # trace add variable $varName unset ::http::CancelReadPipeline
+ dict set DoLater -traceread 1
}
if {![info exists socketWrState($state(socketinfo))]} {
- set socketWrState($state(socketinfo)) {}
- # set varName ::http::socketWrState($state(socketinfo))
- # trace add variable $varName unset ::http::CancelWritePipeline
- dict set DoLater -tracewrite 1
+ set socketWrState($state(socketinfo)) {}
+ # set varName ::http::socketWrState($state(socketinfo))
+ # trace add variable $varName unset ::http::CancelWritePipeline
+ dict set DoLater -tracewrite 1
}
if {$state(-pipeline)} {
- #Log new, init for pipelined, GRANT write access to $token in geturl
- # Also grant premature read access to the socket. This is OK.
- set socketRdState($state(socketinfo)) $token
- set socketWrState($state(socketinfo)) $token
+ #Log new, init for pipelined, GRANT write access to $token in geturl
+ # Also grant premature read access to the socket. This is OK.
+ set socketRdState($state(socketinfo)) $token
+ set socketWrState($state(socketinfo)) $token
} else {
- # socketWrState is not used by this non-pipelined transaction.
- # We cannot leave it as "Wready" because the next call to
- # http::geturl with a pipelined transaction would conclude that the
- # socket is available for writing.
- #Log new, init for nonpipeline, GRANT r/w access to $token in geturl
- set socketRdState($state(socketinfo)) $token
- set socketWrState($state(socketinfo)) $token
+ # socketWrState is not used by this non-pipelined transaction.
+ # We cannot leave it as "Wready" because the next call to
+ # http::geturl with a pipelined transaction would conclude that the
+ # socket is available for writing.
+ #Log new, init for nonpipeline, GRANT r/w access to $token in geturl
+ set socketRdState($state(socketinfo)) $token
+ set socketWrState($state(socketinfo)) $token
}
# Value of socketPhQueue() may have already been set by ReplayCore.
if {![info exists socketPhQueue($state(sock))]} {
- set socketPhQueue($state(sock)) {}
+ set socketPhQueue($state(sock)) {}
}
set socketRdQueue($state(socketinfo)) {}
set socketWrQueue($state(socketinfo)) {}
@@ -1751,8 +1750,8 @@ proc http::OpenSocket {token DoLater} {
Log >K$tk Start OpenSocket coroutine
if {![info exists state(-keepalive)]} {
- # The request has already been cancelled by the calling script.
- return
+ # The request has already been cancelled by the calling script.
+ return
}
set sockOld $state(sock)
@@ -1761,11 +1760,11 @@ proc http::OpenSocket {token DoLater} {
unset -nocomplain state(socketcoro)
if {[catch {
- if {$state(reusing)} {
+ if {$state(reusing)} {
# If ($state(reusing)) is true, then we do not need to create a new
# socket, even if $sockOld is only a placeholder for a socket.
- set sock $sockOld
- } else {
+ set sock $sockOld
+ } else {
# set sock in the [catch] below.
set pre [clock milliseconds]
##Log pre socket opened, - token $token
@@ -1789,14 +1788,14 @@ proc http::OpenSocket {token DoLater} {
fconfigure $sock -profile replace
}
##Log socket opened, DONE fconfigure - token $token
- }
+ }
- Log "Using $sock for $state(socketinfo) - token $token" \
+ Log "Using $sock for $state(socketinfo) - token $token" \
[expr {$state(-keepalive)?"keepalive":""}]
- # Code above has set state(sock) $sock
- ConfigureNewSocket $token $sockOld $DoLater
- ##Log OpenSocket success $sock - token $token
+ # Code above has set state(sock) $sock
+ ConfigureNewSocket $token $sockOld $DoLater
+ ##Log OpenSocket success $sock - token $token
} result errdict]} {
##Log OpenSocket failed $result - token $token
# There may be other requests in the socketPhQueue.
@@ -1812,7 +1811,7 @@ proc http::OpenSocket {token DoLater} {
set socketPlayCmd($state(socketinfo)) [list ReplayIfClose Wready {} $socketPhQueue($sockOld)]
set socketPhQueue($sockOld) {}
}
- if {[string range $result 0 20] eq {proxy connect failed:}} {
+ if {[string range $result 0 20] eq {proxy connect failed:}} {
# - The HTTPS proxy did not create a socket. The pre-existing value
# (a "placeholder socket") is unchanged.
# - The proxy returned a valid HTTP response to the failed CONNECT
@@ -1887,38 +1886,38 @@ proc http::ConfigureNewSocket {token sockOld DoLater} {
##Log " ConfigureNewSocket" $token $sockOld ... -- $reusing $sock $proxyUsed
if {(!$reusing) && ($sock ne $sockOld)} {
- # Replace the placeholder value sockOld with sock.
-
- if { [info exists socketMapping($state(socketinfo))]
- && ($socketMapping($state(socketinfo)) eq $sockOld)
- } {
- set socketMapping($state(socketinfo)) $sock
- set socketProxyId($state(socketinfo)) $proxyUsed
- # tokens that use the placeholder $sockOld are updated below.
- ##Log set socketMapping($state(socketinfo)) $sock
- }
-
- # Now finish any tasks left over from PreparePersistentConnection on
- # the connection.
- #
- # The "unset" traces are fired by init (clears entire arrays), and
- # by http::Unset.
- # Unset is called by CloseQueuedQueries and (possibly never) by geturl.
- #
- # CancelReadPipeline, CancelWritePipeline call http::Finish for each
- # token.
- #
- # FIXME If Finish is placeholder-aware, these traces can be set earlier,
- # in PreparePersistentConnection.
-
- if {[dict get $DoLater -traceread]} {
+ # Replace the placeholder value sockOld with sock.
+
+ if { [info exists socketMapping($state(socketinfo))]
+ && ($socketMapping($state(socketinfo)) eq $sockOld)
+ } {
+ set socketMapping($state(socketinfo)) $sock
+ set socketProxyId($state(socketinfo)) $proxyUsed
+ # tokens that use the placeholder $sockOld are updated below.
+ ##Log set socketMapping($state(socketinfo)) $sock
+ }
+
+ # Now finish any tasks left over from PreparePersistentConnection on
+ # the connection.
+ #
+ # The "unset" traces are fired by init (clears entire arrays), and
+ # by http::Unset.
+ # Unset is called by CloseQueuedQueries and (possibly never) by geturl.
+ #
+ # CancelReadPipeline, CancelWritePipeline call http::Finish for each
+ # token.
+ #
+ # FIXME If Finish is placeholder-aware, these traces can be set earlier,
+ # in PreparePersistentConnection.
+
+ if {[dict get $DoLater -traceread]} {
set varName ::http::socketRdState($state(socketinfo))
trace add variable $varName unset ::http::CancelReadPipeline
- }
- if {[dict get $DoLater -tracewrite]} {
+ }
+ if {[dict get $DoLater -tracewrite]} {
set varName ::http::socketWrState($state(socketinfo))
trace add variable $varName unset ::http::CancelWritePipeline
- }
+ }
}
# Do this in all cases.
@@ -1926,11 +1925,11 @@ proc http::ConfigureNewSocket {token sockOld DoLater} {
# Now look at all other tokens that use the placeholder $sockOld.
if { (!$reusing)
- && ($sock ne $sockOld)
- && [info exists socketPhQueue($sockOld)]
+ && ($sock ne $sockOld)
+ && [info exists socketPhQueue($sockOld)]
} {
- ##Log " ConfigureNewSocket" $token scheduled, now do $socketPhQueue($sockOld)
- foreach tok $socketPhQueue($sockOld) {
+ ##Log " ConfigureNewSocket" $token scheduled, now do $socketPhQueue($sockOld)
+ foreach tok $socketPhQueue($sockOld) {
# 1. Amend the token's (sock).
##Log set ${tok}(sock) $sock
set ${tok}(sock) $sock
@@ -2085,21 +2084,21 @@ proc http::ScheduleRequest {token} {
lappend socketWrQueue($state(socketinfo)) $token
} else {
- if {$reusing && $state(-pipeline)} {
+ if {$reusing && $state(-pipeline)} {
#Log new, init for pipelined, GRANT write access to $token in geturl
# DO NOT grant premature read access to the socket.
- # set socketRdState($state(socketinfo)) $token
- set socketWrState($state(socketinfo)) $token
- } elseif {$reusing} {
+ # set socketRdState($state(socketinfo)) $token
+ set socketWrState($state(socketinfo)) $token
+ } elseif {$reusing} {
# socketWrState is not used by this non-pipelined transaction.
# We cannot leave it as "Wready" because the next call to
# http::geturl with a pipelined transaction would conclude that the
# socket is available for writing.
#Log new, init for nonpipeline, GRANT r/w access to $token in geturl
- set socketRdState($state(socketinfo)) $token
- set socketWrState($state(socketinfo)) $token
- } else {
- }
+ set socketRdState($state(socketinfo)) $token
+ set socketWrState($state(socketinfo)) $token
+ } else {
+ }
# Process the request now.
# - Command is not called unless $state(sock) is a real socket handle
@@ -2115,7 +2114,7 @@ proc http::ScheduleRequest {token} {
##Log " ScheduleRequest" $token -- fileevent $state(sock) writable for $token
# Connect does its own fconfigure.
- lassign $state(connArgs) proto phost srvurl
+ lassign $state(connArgs) proto phost srvurl
if {[catch {
fileevent $state(sock) writable \
@@ -2284,11 +2283,11 @@ proc http::Connected {token proto phost srvurl} {
# and "state(-keepalive) 0".
set ConnVal close
}
- # Proxy authorisation (cf. mod by Anders Ramdahl to autoproxy by
- # Pat Thoyts).
- if {($http(-proxyauth) ne {}) && ($state(proxyUsed) eq {HttpProxy})} {
+ # Proxy authorisation (cf. mod by Anders Ramdahl to autoproxy by
+ # Pat Thoyts).
+ if {($http(-proxyauth) ne {}) && ($state(proxyUsed) eq {HttpProxy})} {
SendHeader $token Proxy-Authorization $http(-proxyauth)
- }
+ }
# RFC7230 A.1 - "clients are encouraged not to send the
# Proxy-Connection header field in any requests"
set accept_encoding_seen 0
@@ -2314,7 +2313,7 @@ proc http::Connected {token proto phost srvurl} {
set state(querylength) $value
}
if { [string equal -nocase $key "connection"]
- && [info exists state(bypass)]
+ && [info exists state(bypass)]
} {
# Value supplied in -headers overrides $ConnVal.
set connection_seen 1
@@ -2606,9 +2605,9 @@ proc http::ReceiveResponse {token} {
coroutine ${token}--EventCoroutine http::Event $sock $token
if {[info exists state(-handler)] || [info exists state(-progress)]} {
- fileevent $sock readable [list http::EventGateway $sock $token]
+ fileevent $sock readable [list http::EventGateway $sock $token]
} else {
- fileevent $sock readable ${token}--EventCoroutine
+ fileevent $sock readable ${token}--EventCoroutine
}
return
}
@@ -2634,15 +2633,15 @@ proc http::EventGateway {sock token} {
fileevent $sock readable {}
catch {${token}--EventCoroutine} res opts
if {[info commands ${token}--EventCoroutine] ne {}} {
- # The coroutine can be deleted by completion (a non-yield return), by
- # http::Finish (when there is a premature end to the transaction), by
- # http::reset or http::cleanup, or if the caller set option -channel
- # but not option -handler: in the last case reading from the socket is
- # now managed by commands ::http::Copy*, http::ReceiveChunked, and
- # http::MakeTransformationChunked.
- #
- # Catch in case the coroutine has closed the socket.
- catch {fileevent $sock readable [list http::EventGateway $sock $token]}
+ # The coroutine can be deleted by completion (a non-yield return), by
+ # http::Finish (when there is a premature end to the transaction), by
+ # http::reset or http::cleanup, or if the caller set option -channel
+ # but not option -handler: in the last case reading from the socket is
+ # now managed by commands ::http::Copy*, http::ReceiveChunked, and
+ # http::MakeTransformationChunked.
+ #
+ # Catch in case the coroutine has closed the socket.
+ catch {fileevent $sock readable [list http::EventGateway $sock $token]}
}
# If there was an error, re-throw it.
@@ -3048,9 +3047,9 @@ proc http::ReInit {token} {
unset state(after)
}
if {[info exists state(socketcoro)]} {
- Log $token Cancel socket after-idle event (ReInit)
- after cancel $state(socketcoro)
- unset state(socketcoro)
+ Log $token Cancel socket after-idle event (ReInit)
+ after cancel $state(socketcoro)
+ unset state(socketcoro)
}
# Don't alter state(status) - this would trigger http::wait if it is in use.
@@ -3210,17 +3209,17 @@ proc http::size {token} {
proc http::requestHeaders {token args} {
set lenny [llength $args]
if {$lenny > 1} {
- return -code error {usage: ::http::requestHeaders token ?headerName?}
+ return -code error {usage: ::http::requestHeaders token ?headerName?}
} else {
- return [Meta $token request {*}$args]
+ return [Meta $token request {*}$args]
}
}
proc http::responseHeaders {token args} {
set lenny [llength $args]
if {$lenny > 1} {
- return -code error {usage: ::http::responseHeaders token ?headerName?}
+ return -code error {usage: ::http::responseHeaders token ?headerName?}
} else {
- return [Meta $token response {*}$args]
+ return [Meta $token response {*}$args]
}
}
proc http::requestHeaderValue {token header} {
@@ -3234,34 +3233,34 @@ proc http::Meta {token who args} {
upvar 0 $token state
if {$who eq {request}} {
- set whom requestHeaders
+ set whom requestHeaders
} elseif {$who eq {response}} {
- set whom meta
+ set whom meta
} else {
- return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??}
+ return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??}
}
set header [string tolower [lindex $args 0]]
set how [string tolower [lindex $args 1]]
set lenny [llength $args]
if {$lenny == 0} {
- return $state($whom)
+ return $state($whom)
} elseif {($lenny > 2) || (($lenny == 2) && ($how ne {value}))} {
- return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??}
+ return -code error {usage: ::http::Meta token request|response ?headerName ?VALUE??}
} else {
- set result {}
- set combined {}
- foreach {key value} $state($whom) {
- if {$key eq $header} {
- lappend result $key $value
- append combined $value {, }
- }
- }
- if {$lenny == 1} {
- return $result
- } else {
- return [string range $combined 0 end-2]
- }
+ set result {}
+ set combined {}
+ foreach {key value} $state($whom) {
+ if {$key eq $header} {
+ lappend result $key $value
+ append combined $value {, }
+ }
+ }
+ if {$lenny == 1} {
+ return $result
+ } else {
+ return [string range $combined 0 end-2]
+ }
}
}
@@ -3283,56 +3282,56 @@ proc http::responseInfo {token} {
upvar 0 $token state
set result {}
foreach {key origin name} {
- stage STATE state
- status STATE status
- responseCode STATE responseCode
- reasonPhrase STATE reasonPhrase
- contentType STATE type
- binary STATE binary
- redirection RESP location
- upgrade STATE upgrade
- error ERROR -
- postError STATE posterror
- method STATE method
- charset STATE charset
- compression STATE coding
- httpRequest STATE -protocol
- httpResponse STATE httpResponse
- url STATE url
- connectionRequest REQ connection
- connectionResponse RESP connection
- connectionActual STATE connection
- transferEncoding STATE transfer
- totalPost STATE querylength
- currentPost STATE queryoffset
- totalSize STATE totalsize
- currentSize STATE currentsize
- proxyUsed STATE proxyUsed
+ stage STATE state
+ status STATE status
+ responseCode STATE responseCode
+ reasonPhrase STATE reasonPhrase
+ contentType STATE type
+ binary STATE binary
+ redirection RESP location
+ upgrade STATE upgrade
+ error ERROR -
+ postError STATE posterror
+ method STATE method
+ charset STATE charset
+ compression STATE coding
+ httpRequest STATE -protocol
+ httpResponse STATE httpResponse
+ url STATE url
+ connectionRequest REQ connection
+ connectionResponse RESP connection
+ connectionActual STATE connection
+ transferEncoding STATE transfer
+ totalPost STATE querylength
+ currentPost STATE queryoffset
+ totalSize STATE totalsize
+ currentSize STATE currentsize
+ proxyUsed STATE proxyUsed
} {
- if {$origin eq {STATE}} {
- if {[info exists state($name)]} {
- dict set result $key $state($name)
- } else {
- # Should never come here
- dict set result $key {}
- }
- } elseif {$origin eq {REQ}} {
- dict set result $key [requestHeaderValue $token $name]
- } elseif {$origin eq {RESP}} {
- dict set result $key [responseHeaderValue $token $name]
- } elseif {$origin eq {ERROR}} {
- # Don't flood the dict with data. The command ::http::error is
- # available.
- if {[info exists state(error)]} {
- set msg [lindex $state(error) 0]
- } else {
- set msg {}
- }
- dict set result $key $msg
- } else {
- # Should never come here
- dict set result $key {}
- }
+ if {$origin eq {STATE}} {
+ if {[info exists state($name)]} {
+ dict set result $key $state($name)
+ } else {
+ # Should never come here
+ dict set result $key {}
+ }
+ } elseif {$origin eq {REQ}} {
+ dict set result $key [requestHeaderValue $token $name]
+ } elseif {$origin eq {RESP}} {
+ dict set result $key [responseHeaderValue $token $name]
+ } elseif {$origin eq {ERROR}} {
+ # Don't flood the dict with data. The command ::http::error is
+ # available.
+ if {[info exists state(error)]} {
+ set msg [lindex $state(error) 0]
+ } else {
+ set msg {}
+ }
+ dict set result $key $msg
+ } else {
+ # Should never come here
+ dict set result $key {}
+ }
}
return $result
}
@@ -3377,9 +3376,9 @@ proc http::cleanup {token} {
unset state(after)
}
if {[info exists state(socketcoro)]} {
- Log $token Cancel socket after-idle event (cleanup)
- after cancel $state(socketcoro)
- unset state(socketcoro)
+ Log $token Cancel socket after-idle event (cleanup)
+ after cancel $state(socketcoro)
+ unset state(socketcoro)
}
if {[info exists state]} {
unset state
@@ -3404,11 +3403,11 @@ proc http::Connect {token proto phost srvurl} {
set tk [namespace tail $token]
if {[catch {eof $state(sock)} tmp] || $tmp} {
- set err "due to unexpected EOF"
+ set err "due to unexpected EOF"
} elseif {[set err [fconfigure $state(sock) -error]] ne ""} {
- # set err is done in test
+ # set err is done in test
} else {
- # All OK
+ # All OK
set state(state) connecting
fileevent $state(sock) writable {}
::http::Connected $token $proto $phost $srvurl
@@ -3821,9 +3820,9 @@ proc http::Event {sock token} {
rename ${token}--SocketCoroutine {}
}
if {[info exists state(socketcoro)]} {
- Log $token Cancel socket after-idle event (Finish)
- after cancel $state(socketcoro)
- unset state(socketcoro)
+ Log $token Cancel socket after-idle event (Finish)
+ after cancel $state(socketcoro)
+ unset state(socketcoro)
}
if {[info exists state(after)]} {
after cancel $state(after)
@@ -4647,14 +4646,14 @@ proc http::GuessType {token} {
upvar 0 $token state
if {$state(type) ne {application/octet-stream}} {
- return 0
+ return 0
}
set body $state(body)
# e.g. {<?xml version="1.0" encoding="utf-8"?> ...}
if {![regexp -nocase -- {^<[?]xml[[:space:]][^>?]*[?]>} $body match]} {
- return 0
+ return 0
}
# e.g. {<?xml version="1.0" encoding="utf-8"?>}
@@ -4664,21 +4663,21 @@ proc http::GuessType {token} {
# without excess whitespace or upper-case letters
if {![regexp -- {^([^=" ]+="[^"]+" )+$} "$contents "]} {
- return 0
+ return 0
}
# The application/xml default encoding:
set res utf-8
set tagList [regexp -all -inline -- {[^=" ]+="[^"]+"} $contents]
foreach tag $tagList {
- regexp -- {([^=" ]+)="([^"]+)"} $tag -> name value
- if {$name eq {encoding}} {
- set res $value
- }
+ regexp -- {([^=" ]+)="([^"]+)"} $tag -> name value
+ if {$name eq {encoding}} {
+ set res $value
+ }
}
set enc [CharsetToEncoding $res]
if {$enc eq "binary"} {
- return 0
+ return 0
}
if {[package vsatisfies [package provide Tcl] 9.0-]} {
set state(body) [encoding convertfrom -profile replace $enc $state(body)]
@@ -4729,10 +4728,10 @@ proc http::wait {token} {
proc http::formatQuery {args} {
if {[llength $args] % 2} {
- return \
- -code error \
- -errorcode [list HTTP BADARGCNT $args] \
- {Incorrect number of arguments, must be an even number.}
+ return \
+ -code error \
+ -errorcode [list HTTP BADARGCNT $args] \
+ {Incorrect number of arguments, must be an even number.}
}
set result ""
set sep ""
@@ -4785,7 +4784,7 @@ proc http::quoteString {string} {
proc http::ProxyRequired {host} {
variable http
if {(![info exists http(-proxyhost)]) || ($http(-proxyhost) eq {})} {
- return
+ return
}
if {![info exists http(-proxyport)] || ($http(-proxyport) eq {})} {
set port 8080
@@ -4796,9 +4795,9 @@ proc http::ProxyRequired {host} {
# Simple test (cf. autoproxy) for hosts that must be accessed directly,
# not through the proxy server.
foreach domain $http(-proxynot) {
- if {[string match -nocase $domain $host]} {
- return {}
- }
+ if {[string match -nocase $domain $host]} {
+ return {}
+ }
}
return [list $http(-proxyhost) $port]
}
@@ -5011,29 +5010,29 @@ proc http::socketAsCallback {args} {
set targ [lsearch -exact $args -type]
if {$targ != -1} {
- set token [lindex $args $targ+1]
- upvar 0 ${token} state
- set protoProxyConn $state(protoProxyConn)
+ set token [lindex $args $targ+1]
+ upvar 0 ${token} state
+ set protoProxyConn $state(protoProxyConn)
} else {
- set protoProxyConn 0
+ set protoProxyConn 0
}
set host [lindex $args end-1]
set port [lindex $args end]
if { ($http(-proxyfilter) ne {})
- && (![catch {$http(-proxyfilter) $host} proxy])
- && $protoProxyConn
+ && (![catch {$http(-proxyfilter) $host} proxy])
+ && $protoProxyConn
} {
- set phost [lindex $proxy 0]
- set pport [lindex $proxy 1]
+ set phost [lindex $proxy 0]
+ set pport [lindex $proxy 1]
} else {
- set phost {}
- set pport {}
+ set phost {}
+ set pport {}
}
if {$phost eq ""} {
- set sock [::http::AltSocket {*}$args]
+ set sock [::http::AltSocket {*}$args]
} else {
- set sock [::http::SecureProxyConnect {*}$args $phost $pport]
+ set sock [::http::SecureProxyConnect {*}$args $phost $pport]
}
return $sock
}
@@ -5079,8 +5078,8 @@ proc http::SecureProxyConnect {args} {
set phost [lindex $args end-1]
set pport [lindex $args end]
if {[string first : $phost] != -1} {
- # IPv6 address, wrap it in [] so we can append :pport
- set phost "\[${phost}\]"
+ # IPv6 address, wrap it in [] so we can append :pport
+ set phost "\[${phost}\]"
}
set url http://${phost}:${pport}
# Elements of args other than host and port are not used when
@@ -5091,21 +5090,21 @@ proc http::SecureProxyConnect {args} {
set targ [lsearch -exact $args -type]
if {$targ != -1} {
- # Record in the token that this is a proxy call.
- set token [lindex $args $targ+1]
- upvar 0 ${token} state
- set tim $state(-timeout)
- set state(proxyUsed) SecureProxyFailed
- # This value is overwritten with "SecureProxy" below if the CONNECT is
- # successful. If it is unsuccessful, the socket will be closed
- # below, and so in this unsuccessful case there are no other transactions
- # whose (proxyUsed) must be updated.
+ # Record in the token that this is a proxy call.
+ set token [lindex $args $targ+1]
+ upvar 0 ${token} state
+ set tim $state(-timeout)
+ set state(proxyUsed) SecureProxyFailed
+ # This value is overwritten with "SecureProxy" below if the CONNECT is
+ # successful. If it is unsuccessful, the socket will be closed
+ # below, and so in this unsuccessful case there are no other transactions
+ # whose (proxyUsed) must be updated.
} else {
- set tim 0
+ set tim 0
}
if {$tim == 0} {
- # Do not use infinite timeout for the proxy.
- set tim 30000
+ # Do not use infinite timeout for the proxy.
+ set tim 30000
}
# Prepare and send a CONNECT request to the proxy, using
@@ -5113,11 +5112,11 @@ proc http::SecureProxyConnect {args} {
set requestHeaders [list Host $host]
lappend requestHeaders Connection keep-alive
if {$http(-proxyauth) != {}} {
- lappend requestHeaders Proxy-Authorization $http(-proxyauth)
+ lappend requestHeaders Proxy-Authorization $http(-proxyauth)
}
set token2 [CreateToken $url -keepalive 0 -timeout $tim \
- -headers $requestHeaders -command [list http::AllDone $varName]]
+ -headers $requestHeaders -command [list http::AllDone $varName]]
variable $token2
upvar 0 $token2 state2
@@ -5131,61 +5130,61 @@ proc http::SecureProxyConnect {args} {
AsyncTransaction $token2
if {[info coroutine] ne {}} {
- # All callers in the http package are coroutines launched by
- # the event loop.
- # The cwait command requires a coroutine because it yields
- # to the caller; $varName is traced and the coroutine resumes
- # when the variable is written.
- cwait $varName
+ # All callers in the http package are coroutines launched by
+ # the event loop.
+ # The cwait command requires a coroutine because it yields
+ # to the caller; $varName is traced and the coroutine resumes
+ # when the variable is written.
+ cwait $varName
} else {
- return -code error {code must run in a coroutine}
- # For testing with a non-coroutine caller outside the http package.
- # vwait $varName
+ return -code error {code must run in a coroutine}
+ # For testing with a non-coroutine caller outside the http package.
+ # vwait $varName
}
unset $varName
if { ($state2(state) ne "complete")
- || ($state2(status) ne "ok")
- || (![string is integer -strict $state2(responseCode)])
+ || ($state2(status) ne "ok")
+ || (![string is integer -strict $state2(responseCode)])
} {
- set msg {the HTTP request to the proxy server did not return a valid\
- and complete response}
- if {[info exists state2(error)]} {
- append msg ": " [lindex $state2(error) 0]
- }
- cleanup $token2
- return -code error $msg
+ set msg {the HTTP request to the proxy server did not return a valid\
+ and complete response}
+ if {[info exists state2(error)]} {
+ append msg ": " [lindex $state2(error) 0]
+ }
+ cleanup $token2
+ return -code error $msg
}
set code $state2(responseCode)
if {($code >= 200) && ($code < 300)} {
- # All OK. The caller in package tls will now call "tls::import $sock".
- # The cleanup command does not close $sock.
- # Other tidying was done in http::Event.
+ # All OK. The caller in package tls will now call "tls::import $sock".
+ # The cleanup command does not close $sock.
+ # Other tidying was done in http::Event.
- # If this is a persistent socket, any other transactions that are
- # already marked to use the socket will have their (proxyUsed) updated
- # when http::OpenSocket calls http::ConfigureNewSocket.
- set state(proxyUsed) SecureProxy
- set sock $state2(sock)
- cleanup $token2
- return $sock
+ # If this is a persistent socket, any other transactions that are
+ # already marked to use the socket will have their (proxyUsed) updated
+ # when http::OpenSocket calls http::ConfigureNewSocket.
+ set state(proxyUsed) SecureProxy
+ set sock $state2(sock)
+ cleanup $token2
+ return $sock
}
if {$targ != -1} {
- # Non-OK HTTP status code; token is known because option -type
- # (cf. targ) was passed through tcltls, and so the useful
- # parts of the proxy's response can be copied to state(*).
- # Do not copy state2(sock).
- # Return the proxy response to the caller of geturl.
- foreach name $failedProxyValues {
- if {[info exists state2($name)]} {
- set state($name) $state2($name)
- }
- }
- set state(connection) close
- set msg "proxy connect failed: $code"
+ # Non-OK HTTP status code; token is known because option -type
+ # (cf. targ) was passed through tcltls, and so the useful
+ # parts of the proxy's response can be copied to state(*).
+ # Do not copy state2(sock).
+ # Return the proxy response to the caller of geturl.
+ foreach name $failedProxyValues {
+ if {[info exists state2($name)]} {
+ set state($name) $state2($name)
+ }
+ }
+ set state(connection) close
+ set msg "proxy connect failed: $code"
# - This error message will be detected by http::OpenSocket and will
# cause it to present the proxy's HTTP response as that of the
# original $token transaction, identified only by state(proxyUsed)
@@ -5272,25 +5271,25 @@ proc http::AltSocket {args} {
set targ [lsearch -exact $args -type]
if {$targ != -1} {
- set token [lindex $args $targ+1]
- set args [lreplace $args $targ $targ+1]
- upvar 0 $token state
+ set token [lindex $args $targ+1]
+ set args [lreplace $args $targ $targ+1]
+ upvar 0 $token state
}
if {$http(usingThread) && [info exists state] && $state(protoSockThread)} {
} else {
- # Use plain "::socket". This is the default.
- return [eval ::socket $args]
+ # Use plain "::socket". This is the default.
+ return [eval ::socket $args]
}
set defcmd ::socket
set sockargs $args
set script "
- set code \[catch {
- [list proc ::SockInThread {caller defcmd sockargs} [info body ::http::SockInThread]]
- [list ::SockInThread [thread::id] $defcmd $sockargs]
- } result opts\]
- list \$code \$opts \$result
+ set code \[catch {
+ [list proc ::SockInThread {caller defcmd sockargs} [info body ::http::SockInThread]]
+ [list ::SockInThread [thread::id] $defcmd $sockargs]
+ } result opts\]
+ list \$code \$opts \$result
"
set state(tid) [thread::create]
@@ -5298,16 +5297,16 @@ proc http::AltSocket {args} {
thread::send -async $state(tid) $script $varName
Log >T Thread Start Wait $args -- coro [info coroutine] $varName
if {[info coroutine] ne {}} {
- # All callers in the http package are coroutines launched by
- # the event loop.
- # The cwait command requires a coroutine because it yields
- # to the caller; $varName is traced and the coroutine resumes
- # when the variable is written.
- cwait $varName
+ # All callers in the http package are coroutines launched by
+ # the event loop.
+ # The cwait command requires a coroutine because it yields
+ # to the caller; $varName is traced and the coroutine resumes
+ # when the variable is written.
+ cwait $varName
} else {
- return -code error {code must run in a coroutine}
- # For testing with a non-coroutine caller outside the http package.
- # vwait $varName
+ return -code error {code must run in a coroutine}
+ # For testing with a non-coroutine caller outside the http package.
+ # vwait $varName
}
Log >U Thread End Wait $args -- coro [info coroutine] $varName [set $varName]
thread::release $state(tid)
@@ -5315,20 +5314,20 @@ proc http::AltSocket {args} {
set result [set $varName]
unset $varName
if {(![string is list $result]) || ([llength $result] != 3)} {
- return -code error "result from peer thread is not a list of\
- length 3: it is \n$result"
+ return -code error "result from peer thread is not a list of\
+ length 3: it is \n$result"
}
lassign $result threadCode threadDict threadResult
if {($threadCode != 0)} {
- # This is an error in thread::send. Return the lot.
- return -options $threadDict -code error $threadResult
+ # This is an error in thread::send. Return the lot.
+ return -options $threadDict -code error $threadResult
}
# Now the results of the catch in the peer thread.
lassign $threadResult catchCode errdict sock
if {($catchCode == 0) && ($sock ni [chan names])} {
- return -code error {Transfer of socket from peer thread failed.\
+ return -code error {Transfer of socket from peer thread failed.\
Check that this script is not running in a child interpreter.}
}
return -options $errdict -code $catchCode $sock
@@ -5356,17 +5355,17 @@ proc http::AltSocket {args} {
proc http::LoadThreadIfNeeded {} {
variable http
if {$http(-threadlevel) == 0} {
- set http(usingThread) 0
- return
+ set http(usingThread) 0
+ return
}
if {[catch {package require Thread}]} {
- if {$http(-threadlevel) == 2} {
- set msg {[http::config -threadlevel] has value 2,\
- but the Thread package is not available}
- return -code error $msg
- }
- set http(usingThread) 0
- return
+ if {$http(-threadlevel) == 2} {
+ set msg {[http::config -threadlevel] has value 2,\
+ but the Thread package is not available}
+ return -code error $msg
+ }
+ set http(usingThread) 0
+ return
}
set http(usingThread) 1
return
@@ -5393,7 +5392,7 @@ proc http::SockInThread {caller defcmd sockargs} {
set catchCode [catch {eval $defcmd $sockargs} sock errdict]
if {$catchCode == 0} {
- set catchCode [catch {thread::transfer $caller $sock; set sock} sock errdict]
+ set catchCode [catch {thread::transfer $caller $sock; set sock} sock errdict]
}
return [list $catchCode $errdict $sock]
}
@@ -5430,20 +5429,20 @@ proc http::cwaiter::cwait {
} {
set thisCoro [info coroutine]
if {$thisCoro eq {}} {
- return -code error {cwait cannot be called outside a coroutine}
+ return -code error {cwait cannot be called outside a coroutine}
}
if {$coroName eq {}} {
- set coroName $thisCoro
+ set coroName $thisCoro
}
if {[string range $varName 0 1] ne {::}} {
- return -code error {argument varName must be fully qualified}
+ return -code error {argument varName must be fully qualified}
}
if {$timeout eq {}} {
- set toe {}
+ set toe {}
} elseif {[string is integer -strict $timeout] && ($timeout > 0)} {
- set toe [after $timeout [list set $varName $timeoutValue]]
+ set toe [after $timeout [list set $varName $timeoutValue]]
} else {
- return -code error {if timeout is supplied it must be a positive integer}
+ return -code error {if timeout is supplied it must be a positive integer}
}
set cmd [list ::http::cwaiter::CwaitHelper $varName $coroName $toe]
@@ -5501,7 +5500,7 @@ proc http::cwaiter::CoLog {msg} {
variable log
variable logOn
if {$logOn} {
- append log $msg \n
+ append log $msg \n
}
return
}
diff --git a/library/init.tcl b/library/init.tcl
index 72d0e75..9658991 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -554,12 +554,12 @@ proc auto_import {pattern} {
auto_load_index
foreach pattern $patternList {
- foreach name [array names auto_index $pattern] {
- if {([namespace which -command $name] eq "")
+ foreach name [array names auto_index $pattern] {
+ if {([namespace which -command $name] eq "")
&& ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} {
- namespace inscope :: $auto_index($name)
- }
- }
+ namespace inscope :: $auto_index($name)
+ }
+ }
}
}
diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl
index f6e5224..eaaafa8 100644
--- a/library/msgcat/msgcat.tcl
+++ b/library/msgcat/msgcat.tcl
@@ -20,7 +20,7 @@ package provide msgcat 1.7.1
namespace eval msgcat {
namespace export mc mcn mcexists mcload mclocale mcmax\
mcmset mcpreferences mcset\
- mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\
+ mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\
mcpackagenamespaceget mcpackageconfig mcpackagelocale mcutil
# Records the list of locales to search
@@ -738,7 +738,7 @@ proc msgcat::mcpackageconfig {subcommand option {value ""}} {
\"[lrange [info level 0] 0 2] value\""
}
} elseif {$subcommand eq "set"} {
- return -code error\
+ return -code error\
"wrong # args: should be \"[lrange [info level 0] 0 2]\""
}
diff --git a/library/opt/optparse.tcl b/library/opt/optparse.tcl
index d8883fe..7225edd 100644
--- a/library/opt/optparse.tcl
+++ b/library/opt/optparse.tcl
@@ -17,10 +17,10 @@ namespace eval ::tcl {
# Exported APIs
namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
- OptProc OptProcArgGiven OptParse \
- Lempty Lget \
- Lassign Lvarpop Lvarpop1 Lvarset Lvarincr \
- SetMax SetMin
+ OptProc OptProcArgGiven OptParse \
+ Lempty Lget \
+ Lassign Lvarpop Lvarpop1 Lvarset Lvarincr \
+ SetMax SetMin
################# Example of use / 'user documentation' ###################
@@ -38,28 +38,28 @@ namespace eval ::tcl {
# ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\
# -nostatics false ch1
OptProc OptParseTest {
- {subcommand -choice {save print} "sub command"}
- {arg1 3 "some number"}
- {-aflag}
- {-intflag 7}
- {-weirdflag "help string"}
- {-noStatics "Not ok to load static packages"}
- {-nestedloading1 true "OK to load into nested children"}
- {-nestedloading2 -boolean true "OK to load into nested children"}
- {-libsOK -choice {Tk SybTcl}
- "List of packages that can be loaded"}
- {-precision -int 12 "Number of digits of precision"}
- {-intval 7 "An integer"}
- {-scale -float 1.0 "Scale factor"}
- {-zoom 1.0 "Zoom factor"}
- {-arbitrary foobar "Arbitrary string"}
- {-random -string 12 "Random string"}
- {-listval -list {} "List value"}
- {-blahflag -blah abc "Funny type"}
+ {subcommand -choice {save print} "sub command"}
+ {arg1 3 "some number"}
+ {-aflag}
+ {-intflag 7}
+ {-weirdflag "help string"}
+ {-noStatics "Not ok to load static packages"}
+ {-nestedloading1 true "OK to load into nested children"}
+ {-nestedloading2 -boolean true "OK to load into nested children"}
+ {-libsOK -choice {Tk SybTcl}
+ "List of packages that can be loaded"}
+ {-precision -int 12 "Number of digits of precision"}
+ {-intval 7 "An integer"}
+ {-scale -float 1.0 "Scale factor"}
+ {-zoom 1.0 "Zoom factor"}
+ {-arbitrary foobar "Arbitrary string"}
+ {-random -string 12 "Random string"}
+ {-listval -list {} "List value"}
+ {-blahflag -blah abc "Funny type"}
{arg2 -boolean "a boolean"}
{arg3 -choice "ch1 ch2"}
{?optarg? -list {} "optional argument"}
- } {
+ } {
foreach v [info locals] {
puts stderr [format "%14s : %s" $v [set $v]]
}
@@ -146,10 +146,10 @@ proc ::tcl::OptKeyRegister {desc {key ""}} {
variable OptDesc
variable OptDescN
if {[string equal $key ""]} {
- # in case a key given to us as a parameter was a number
- while {[info exists OptDesc($OptDescN)]} {incr OptDescN}
- set key $OptDescN
- incr OptDescN
+ # in case a key given to us as a parameter was a number
+ while {[info exists OptDesc($OptDescN)]} {incr OptDescN}
+ set key $OptDescN
+ incr OptDescN
}
# program counter
set program [list [list "P" 1]]
@@ -167,31 +167,31 @@ proc ::tcl::OptKeyRegister {desc {key ""}} {
# more items after 'args'...
return -code error "'args' special argument must be the last one"
}
- set res [OptNormalizeOne $item]
- set state [lindex $res 0]
- if {$inflags} {
- if {$state == "flags"} {
+ set res [OptNormalizeOne $item]
+ set state [lindex $res 0]
+ if {$inflags} {
+ if {$state == "flags"} {
# add to 'subprogram'
- lappend flagsprg $res
- } else {
- # put in the flags
- # structure for flag programs items is a list of
- # {subprgcounter {prg flag 1} {prg flag 2} {...}}
- lappend program $flagsprg
- # put the other regular stuff
- lappend program $res
+ lappend flagsprg $res
+ } else {
+ # put in the flags
+ # structure for flag programs items is a list of
+ # {subprgcounter {prg flag 1} {prg flag 2} {...}}
+ lappend program $flagsprg
+ # put the other regular stuff
+ lappend program $res
set inflags 0
set empty 0
- }
- } else {
- if {$state == "flags"} {
- set inflags 1
- # sub program counter + first sub program
- set flagsprg [list [list "P" 1] $res]
- } else {
- lappend program $res
- set empty 0
- }
+ }
+ } else {
+ if {$state == "flags"} {
+ set inflags 1
+ # sub program counter + first sub program
+ set flagsprg [list [list "P" 1] $res]
+ } else {
+ lappend program $res
+ set empty 0
+ }
}
}
if {$inflags} {
@@ -219,11 +219,11 @@ proc ::tcl::OptKeyDelete {key} {
# Get the parsed description stored under the given key.
proc OptKeyGetDesc {descKey} {
- variable OptDesc
- if {![info exists OptDesc($descKey)]} {
- return -code error "Unknown option description key \"$descKey\""
- }
- set OptDesc($descKey)
+ variable OptDesc
+ if {![info exists OptDesc($descKey)]} {
+ return -code error "Unknown option description key \"$descKey\""
+ }
+ set OptDesc($descKey)
}
# Parse entry point for people who don't want to register with a key,
@@ -248,11 +248,11 @@ proc ::tcl::OptParse {desc arglist} {
proc ::tcl::OptProc {name desc body} {
set namespace [uplevel 1 [list ::namespace current]]
if {[string match "::*" $name] || [string equal $namespace "::"]} {
- # absolute name or global namespace, name is the key
- set key $name
+ # absolute name or global namespace, name is the key
+ set key $name
} else {
- # we are relative to some non top level namespace:
- set key "${namespace}::${name}"
+ # we are relative to some non top level namespace:
+ set key "${namespace}::${name}"
}
OptKeyRegister $desc $key
uplevel 1 [list ::proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"]
@@ -300,21 +300,21 @@ proc ::tcl::OptProcArgGiven {argname} {
# Advance to next description
proc OptNextDesc {descName} {
- uplevel 1 [list Lvarincr $descName {0 1}]
+ uplevel 1 [list Lvarincr $descName {0 1}]
}
# Get the current description, eventually descend
proc OptCurDesc {descriptions} {
- lindex $descriptions [OptGetPrgCounter $descriptions]
+ lindex $descriptions [OptGetPrgCounter $descriptions]
}
# get the current description, eventually descend
# through sub programs as needed.
proc OptCurDescFinal {descriptions} {
- set item [OptCurDesc $descriptions]
+ set item [OptCurDesc $descriptions]
# Descend untill we get the actual item and not a sub program
- while {[OptIsPrg $item]} {
- set item [OptCurDesc $item]
- }
+ while {[OptIsPrg $item]} {
+ set item [OptCurDesc $item]
+ }
return $item
}
# Current final instruction adress
@@ -332,7 +332,7 @@ proc ::tcl::OptProcArgGiven {argname} {
proc OptCurSetValue {descriptionsName value} {
upvar $descriptionsName descriptions
# Get the current item full address.
- set adress [OptCurAddr $descriptions]
+ set adress [OptCurAddr $descriptions]
# Use the 3rd field of the item (see OptValue / OptNewInst).
lappend adress 2
Lvarset descriptions $adress [list 1 $value]
@@ -341,12 +341,12 @@ proc ::tcl::OptProcArgGiven {argname} {
# Empty state means done/paste the end of the program.
proc OptState {item} {
- lindex $item 0
+ lindex $item 0
}
# current state
proc OptCurState {descriptions} {
- OptState [OptCurDesc $descriptions]
+ OptState [OptCurDesc $descriptions]
}
#######
@@ -354,11 +354,11 @@ proc ::tcl::OptProcArgGiven {argname} {
# Returns the argument that has to be processed now.
proc OptCurrentArg {lst} {
- lindex $lst 0
+ lindex $lst 0
}
# Advance to next argument.
proc OptNextArg {argsName} {
- uplevel 1 [list Lvarpop1 $argsName]
+ uplevel 1 [list Lvarpop1 $argsName]
}
#######
@@ -377,7 +377,7 @@ proc ::tcl::OptProcArgGiven {argname} {
# when needed...
set state [OptCurState $descriptions]
# We'll exit the loop in "OptDoOne" or when state is empty.
- while 1 {
+ while 1 {
set curitem [OptCurDesc $descriptions]
# Do subprograms if needed, call ourselves on the sub branch
while {[OptIsPrg $curitem]} {
@@ -388,7 +388,7 @@ proc ::tcl::OptProcArgGiven {argname} {
$curitem
OptNextDesc descriptions
set curitem [OptCurDesc $descriptions]
- set state [OptCurState $descriptions]
+ set state [OptCurState $descriptions]
}
# puts "state = \"$state\" - arguments=($arguments)"
if {[Lempty $state]} {
@@ -398,20 +398,20 @@ proc ::tcl::OptProcArgGiven {argname} {
# The following statement can make us terminate/continue
# as it use return -code {break, continue, return and error}
# codes
- OptDoOne descriptions state arguments
+ OptDoOne descriptions state arguments
# If we are here, no special return code where issued,
# we'll step to next instruction :
# puts "new state = \"$state\""
OptNextDesc descriptions
set state [OptCurState $descriptions]
- }
+ }
}
# Process one step for the state machine,
# eventually consuming the current argument.
proc OptDoOne {descriptionsName stateName argumentsName} {
- upvar $argumentsName arguments
- upvar $descriptionsName descriptions
+ upvar $argumentsName arguments
+ upvar $descriptionsName descriptions
upvar $stateName state
# the special state/instruction "args" eats all
@@ -443,48 +443,48 @@ proc ::tcl::OptProcArgGiven {argname} {
set arg [OptCurrentArg $arguments]
}
- switch $state {
- flags {
- # A non-dash argument terminates the options, as does --
-
- # Still a flag ?
- if {![OptIsFlag $arg]} {
- # don't consume the argument, return to previous prg
- return -code return
- }
- # consume the flag
- OptNextArg arguments
- if {[string equal "--" $arg]} {
- # return from 'flags' state
- return -code return
- }
-
- set hits [OptHits descriptions $arg]
- if {$hits > 1} {
- return -code error [OptAmbigous $descriptions $arg]
- } elseif {$hits == 0} {
- return -code error [OptFlagUsage $descriptions $arg]
- }
+ switch $state {
+ flags {
+ # A non-dash argument terminates the options, as does --
+
+ # Still a flag ?
+ if {![OptIsFlag $arg]} {
+ # don't consume the argument, return to previous prg
+ return -code return
+ }
+ # consume the flag
+ OptNextArg arguments
+ if {[string equal "--" $arg]} {
+ # return from 'flags' state
+ return -code return
+ }
+
+ set hits [OptHits descriptions $arg]
+ if {$hits > 1} {
+ return -code error [OptAmbigous $descriptions $arg]
+ } elseif {$hits == 0} {
+ return -code error [OptFlagUsage $descriptions $arg]
+ }
set item [OptCurDesc $descriptions]
- if {[OptNeedValue $item]} {
+ if {[OptNeedValue $item]} {
# we need a value, next state is
set state flagValue
- } else {
- OptCurSetValue descriptions 1
- }
+ } else {
+ OptCurSetValue descriptions 1
+ }
# continue
return -code continue
- }
+ }
flagValue -
value {
set item [OptCurDesc $descriptions]
- # Test the values against their required type
+ # Test the values against their required type
if {[catch {OptCheckType $arg\
[OptType $item] [OptTypeArgs $item]} val]} {
return -code error [OptBadValue $item $arg $val]
}
- # consume the value
- OptNextArg arguments
+ # consume the value
+ OptNextArg arguments
# set the value
OptCurSetValue descriptions $val
# go to next state
@@ -498,7 +498,7 @@ proc ::tcl::OptProcArgGiven {argname} {
}
optValue {
set item [OptCurDesc $descriptions]
- # Test the values against their required type
+ # Test the values against their required type
if {![catch {OptCheckType $arg\
[OptType $item] [OptTypeArgs $item]} val]} {
# right type, so :
@@ -511,7 +511,7 @@ proc ::tcl::OptProcArgGiven {argname} {
set state next; # not used, for debug only
return ; # will go on next step
}
- }
+ }
# If we reach this point: an unknown
# state as been entered !
return -code error "Bug! unknown state in DoOne \"$state\"\
@@ -576,46 +576,46 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
# only types "any", "choice", and numbers can have leading "-"
switch -exact -- $type {
- int {
- if {![string is integer -strict $arg]} {
- error "not an integer"
- }
+ int {
+ if {![string is integer -strict $arg]} {
+ error "not an integer"
+ }
return $arg
- }
- float {
- return [expr {double($arg)}]
- }
+ }
+ float {
+ return [expr {double($arg)}]
+ }
script -
- list {
+ list {
# if llength fail : malformed list
- if {[llength $arg]==0 && [OptIsFlag $arg]} {
+ if {[llength $arg]==0 && [OptIsFlag $arg]} {
error "no values with leading -"
}
return $arg
- }
- boolean {
+ }
+ boolean {
if {![string is boolean -strict $arg]} {
error "non canonic boolean"
- }
+ }
# convert true/false because expr/if is broken with "!,...
return [expr {$arg ? 1 : 0}]
- }
- choice {
- if {$arg ni $typeArgs} {
- error "invalid choice"
- }
+ }
+ choice {
+ if {$arg ni $typeArgs} {
+ error "invalid choice"
+ }
return $arg
- }
+ }
any {
return $arg
}
string -
default {
- if {[OptIsFlag $arg]} {
- error "no values with leading -"
- }
+ if {[OptIsFlag $arg]} {
+ error "no values with leading -"
+ }
return $arg
- }
+ }
}
return neverReached
}
@@ -625,17 +625,17 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
# returns the number of flags matching the given arg
# sets the (local) prg counter to the list of matches
proc OptHits {descName arg} {
- upvar $descName desc
- set hits 0
- set hitems {}
+ upvar $descName desc
+ set hits 0
+ set hitems {}
set i 1
set larg [string tolower $arg]
set len [string length $larg]
set last [expr {$len-1}]
- foreach item [lrange $desc 1 end] {
- set flag [OptName $item]
+ foreach item [lrange $desc 1 end] {
+ set flag [OptName $item]
# lets try to match case insensitively
# (string length ought to be cheap)
set lflag [string tolower $flag]
@@ -648,19 +648,19 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
} elseif {[string equal $larg [string range $lflag 0 $last]]} {
lappend hitems $i
incr hits
- }
+ }
incr i
- }
+ }
if {$hits} {
OptSetPrgCounter desc $hitems
}
- return $hits
+ return $hits
}
# Extract fields from the list structure:
proc OptName {item} {
- lindex $item 1
+ lindex $item 1
}
proc OptHasBeenSet {item} {
Lget $item {2 0}
@@ -670,37 +670,37 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
}
proc OptIsFlag {name} {
- string match "-*" $name
+ string match "-*" $name
}
proc OptIsOpt {name} {
- string match {\?*} $name
+ string match {\?*} $name
}
proc OptVarName {item} {
- set name [OptName $item]
- if {[OptIsFlag $name]} {
- return [string range $name 1 end]
- } elseif {[OptIsOpt $name]} {
+ set name [OptName $item]
+ if {[OptIsFlag $name]} {
+ return [string range $name 1 end]
+ } elseif {[OptIsOpt $name]} {
return [string trim $name "?"]
} else {
- return $name
- }
+ return $name
+ }
}
proc OptType {item} {
- lindex $item 3
+ lindex $item 3
}
proc OptTypeArgs {item} {
- lindex $item 4
+ lindex $item 4
}
proc OptHelp {item} {
- lindex $item 5
+ lindex $item 5
}
proc OptNeedValue {item} {
- expr {![string equal [OptType $item] boolflag]}
+ expr {![string equal [OptType $item] boolflag]}
}
proc OptDefaultValue {item} {
- set val [OptTypeArgs $item]
- switch -exact -- [OptType $item] {
- choice {return [lindex $val 0]}
+ set val [OptTypeArgs $item]
+ switch -exact -- [OptType $item] {
+ choice {return [lindex $val 0]}
boolean -
boolflag {
# convert back false/true to 0/1 because expr !$bool
@@ -711,15 +711,15 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
return 0
}
}
- }
- return $val
+ }
+ return $val
}
# Description format error helper
proc OptOptUsage {item {what ""}} {
- return -code error "invalid description format$what: $item\n\
- should be a list of {varname|-flagname ?-type? ?defaultvalue?\
- ?helpstring?}"
+ return -code error "invalid description format$what: $item\n\
+ should be a list of {varname|-flagname ?-type? ?defaultvalue?\
+ ?helpstring?}"
}
@@ -733,13 +733,13 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
# Translate one item to canonical form
proc OptNormalizeOne {item} {
- set lg [Lassign $item varname arg1 arg2 arg3]
+ set lg [Lassign $item varname arg1 arg2 arg3]
# puts "called optnormalizeone '$item' v=($varname), lg=$lg"
- set isflag [OptIsFlag $varname]
+ set isflag [OptIsFlag $varname]
set isopt [OptIsOpt $varname]
- if {$isflag} {
- set state "flags"
- } elseif {$isopt} {
+ if {$isflag} {
+ set state "flags"
+ } elseif {$isopt} {
set state "optValue"
} elseif {![string equal $varname "args"]} {
set state "value"
@@ -751,20 +751,20 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
# description writer's life easy, and our's difficult :
# let's guess the missing arguments :-)
- switch $lg {
- 1 {
- if {$isflag} {
- return [OptNewInst $state $varname boolflag false ""]
- } else {
- return [OptNewInst $state $varname any "" ""]
- }
- }
- 2 {
- # varname default
- # varname help
- set type [OptGuessType $arg1]
- if {[string equal $type "string"]} {
- if {$isflag} {
+ switch $lg {
+ 1 {
+ if {$isflag} {
+ return [OptNewInst $state $varname boolflag false ""]
+ } else {
+ return [OptNewInst $state $varname any "" ""]
+ }
+ }
+ 2 {
+ # varname default
+ # varname help
+ set type [OptGuessType $arg1]
+ if {[string equal $type "string"]} {
+ if {$isflag} {
set type boolflag
set def false
} else {
@@ -772,67 +772,67 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
set def ""
}
set help $arg1
- } else {
- set help ""
- set def $arg1
- }
- return [OptNewInst $state $varname $type $def $help]
- }
- 3 {
- # varname type value
- # varname value comment
-
- if {[regexp {^-(.+)$} $arg1 x type]} {
+ } else {
+ set help ""
+ set def $arg1
+ }
+ return [OptNewInst $state $varname $type $def $help]
+ }
+ 3 {
+ # varname type value
+ # varname value comment
+
+ if {[regexp {^-(.+)$} $arg1 x type]} {
# flags/optValue as they are optional, need a "value",
# on the contrary, for a variable (non optional),
- # default value is pointless, 'cept for choices :
+ # default value is pointless, 'cept for choices :
if {$isflag || $isopt || ($type == "choice")} {
return [OptNewInst $state $varname $type $arg2 ""]
} else {
return [OptNewInst $state $varname $type "" $arg2]
}
- } else {
- return [OptNewInst $state $varname\
+ } else {
+ return [OptNewInst $state $varname\
[OptGuessType $arg1] $arg1 $arg2]
- }
- }
- 4 {
- if {[regexp {^-(.+)$} $arg1 x type]} {
+ }
+ }
+ 4 {
+ if {[regexp {^-(.+)$} $arg1 x type]} {
return [OptNewInst $state $varname $type $arg2 $arg3]
- } else {
- return -code error [OptOptUsage $item]
- }
- }
- default {
- return -code error [OptOptUsage $item]
- }
- }
+ } else {
+ return -code error [OptOptUsage $item]
+ }
+ }
+ default {
+ return -code error [OptOptUsage $item]
+ }
+ }
}
# Auto magic lazy type determination
proc OptGuessType {arg} {
if { $arg == "true" || $arg == "false" } {
- return boolean
- }
- if {[string is integer -strict $arg]} {
- return int
- }
- if {[string is double -strict $arg]} {
- return float
- }
- return string
+ return boolean
+ }
+ if {[string is integer -strict $arg]} {
+ return int
+ }
+ if {[string is double -strict $arg]} {
+ return float
+ }
+ return string
}
# Error messages front ends
proc OptAmbigous {desc arg} {
- OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc]
+ OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc]
}
proc OptFlagUsage {desc arg} {
- OptError "bad flag \"$arg\", must be one of" $desc
+ OptError "bad flag \"$arg\", must be one of" $desc
}
proc OptTooManyArgs {desc arguments} {
- OptError "too many arguments (unexpected argument(s): $arguments),\
+ OptError "too many arguments (unexpected argument(s): $arguments),\
usage:"\
$desc 1
}
@@ -845,13 +845,13 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
}
proc OptBadValue {item arg {err {}}} {
# puts "bad val err = \"$err\""
- OptError "bad value \"$arg\" for [OptParamType $item]"\
+ OptError "bad value \"$arg\" for [OptParamType $item]"\
[list $item]
}
proc OptMissingValue {descriptions} {
# set item [OptCurDescFinal $descriptions]
- set item [OptCurDesc $descriptions]
- OptError "no value given for [OptParamType $item] \"[OptName $item]\"\
+ set item [OptCurDesc $descriptions]
+ OptError "no value given for [OptParamType $item] \"[OptName $item]\"\
(use -help for full usage) :"\
[list $item]
}
@@ -943,7 +943,7 @@ proc ::tcl::Lempty {list} {
# Gets the value of one leaf of a lists tree
proc ::tcl::Lget {list indexLst} {
if {[llength $indexLst] <= 1} {
- return [lindex $list $indexLst]
+ return [lindex $list $indexLst]
}
Lget [lindex $list [lindex $indexLst 0]] [lrange $indexLst 1 end]
}
@@ -958,17 +958,17 @@ proc ::tcl::Lget {list indexLst} {
proc ::tcl::Lvarset {listName indexLst newValue} {
upvar $listName list
if {[llength $indexLst] <= 1} {
- Lvarset1nc list $indexLst $newValue
+ Lvarset1nc list $indexLst $newValue
} else {
- set idx [lindex $indexLst 0]
- set targetList [lindex $list $idx]
- # reduce refcount on targetList (not really usefull now,
+ set idx [lindex $indexLst 0]
+ set targetList [lindex $list $idx]
+ # reduce refcount on targetList (not really usefull now,
# could be with optimizing compiler)
# Lvarset1 list $idx {}
- # recursively replace in targetList
- Lvarset targetList [lrange $indexLst 1 end] $newValue
- # put updated sub list back in the tree
- Lvarset1nc list $idx $targetList
+ # recursively replace in targetList
+ Lvarset targetList [lrange $indexLst 1 end] $newValue
+ # put updated sub list back in the tree
+ Lvarset1nc list $idx $targetList
}
}
# Set one cell to a value, eventually create all the needed elements
@@ -979,13 +979,13 @@ proc ::tcl::Lvarset1 {listName index newValue} {
if {$index < 0} {return -code error "invalid negative index"}
set lg [llength $list]
if {$index >= $lg} {
- variable emptyList
- for {set i $lg} {$i<$index} {incr i} {
- lappend list $emptyList
- }
- lappend list $newValue
+ variable emptyList
+ for {set i $lg} {$i<$index} {incr i} {
+ lappend list $emptyList
+ }
+ lappend list $newValue
} else {
- set list [lreplace $list $index $index $newValue]
+ set list [lreplace $list $index $index $newValue]
}
}
# same as Lvarset1 but no bound checking / creation
@@ -998,16 +998,16 @@ proc ::tcl::Lvarset1nc {listName index newValue} {
proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} {
upvar $listName list
if {[llength $indexLst] <= 1} {
- Lvarincr1 list $indexLst $howMuch
+ Lvarincr1 list $indexLst $howMuch
} else {
- set idx [lindex $indexLst 0]
- set targetList [lindex $list $idx]
- # reduce refcount on targetList
- Lvarset1nc list $idx {}
- # recursively replace in targetList
- Lvarincr targetList [lrange $indexLst 1 end] $howMuch
- # put updated sub list back in the tree
- Lvarset1nc list $idx $targetList
+ set idx [lindex $indexLst 0]
+ set targetList [lindex $list $idx]
+ # reduce refcount on targetList
+ Lvarset1nc list $idx {}
+ # recursively replace in targetList
+ Lvarincr targetList [lrange $indexLst 1 end] $howMuch
+ # put updated sub list back in the tree
+ Lvarset1nc list $idx $targetList
}
}
# Increments the value of one cell of a list
@@ -1037,9 +1037,9 @@ proc ::tcl::Lassign {list args} {
set i 0
set lg [llength $list]
foreach vname $args {
- if {$i>=$lg} break
- uplevel 1 [list ::set $vname [lindex $list $i]]
- incr i
+ if {$i>=$lg} break
+ uplevel 1 [list ::set $vname [lindex $list $i]]
+ incr i
}
return $lg
}
@@ -1051,7 +1051,7 @@ proc ::tcl::Lassign {list args} {
proc ::tcl::SetMax {varname value} {
upvar 1 $varname var
if {![info exists var] || $value > $var} {
- set var $value
+ set var $value
}
}
@@ -1060,7 +1060,7 @@ proc ::tcl::SetMax {varname value} {
proc ::tcl::SetMin {varname value} {
upvar 1 $varname var
if {![info exists var] || $value < $var} {
- set var $value
+ set var $value
}
}
diff --git a/library/package.tcl b/library/package.tcl
index 118beef..fd455fb 100644
--- a/library/package.tcl
+++ b/library/package.tcl
@@ -31,16 +31,16 @@ proc tcl::Pkg::CompareExtension {fileName {ext {}}} {
global tcl_platform
if {$ext eq ""} {set ext [info sharedlibextension]}
if {$tcl_platform(platform) eq "windows"} {
- return [string equal -nocase [file extension $fileName] $ext]
+ return [string equal -nocase [file extension $fileName] $ext]
} else {
- # Some unices add trailing numbers after the .so, so
- # we could have something like '.so.1.2'.
- set root $fileName
- while {1} {
- set currExt [file extension $root]
- if {$currExt eq $ext} {
- return 1
- }
+ # Some unices add trailing numbers after the .so, so
+ # we could have something like '.so.1.2'.
+ set root $fileName
+ while {1} {
+ set currExt [file extension $root]
+ if {$currExt eq $ext} {
+ return 1
+ }
# The current extension does not match; if it is not a numeric
# value, quit, as we are only looking to ignore version number
@@ -51,7 +51,7 @@ proc tcl::Pkg::CompareExtension {fileName {ext {}}} {
if {![string is integer -strict [string range $currExt 1 end]]} {
return 0
}
- set root [file rootname $root]
+ set root [file rootname $root]
}
}
}
diff --git a/library/platform/shell.tcl b/library/platform/shell.tcl
index a91849c..526a7b1 100644
--- a/library/platform/shell.tcl
+++ b/library/platform/shell.tcl
@@ -131,7 +131,7 @@ proc ::platform::shell::RUN {shell code} {
set e [TEMP]
set code [catch {
- exec $shell $c 2> $e
+ exec $shell $c 2> $e
} res]
file delete $c
diff --git a/library/safe.tcl b/library/safe.tcl
index cc4a194..97139f7 100644
--- a/library/safe.tcl
+++ b/library/safe.tcl
@@ -80,7 +80,7 @@ proc ::safe::InterpNested {} {
proc ::safe::interpCreate {args} {
variable AutoPathSync
if {$AutoPathSync} {
- set autoPath {}
+ set autoPath {}
}
set Args [::tcl::OptKeyParse ::safe::interpCreate $args]
RejectExcessColons $child
@@ -93,7 +93,7 @@ proc ::safe::interpCreate {args} {
proc ::safe::interpInit {args} {
variable AutoPathSync
if {$AutoPathSync} {
- set autoPath {}
+ set autoPath {}
}
set Args [::tcl::OptKeyParse ::safe::interpIC $args]
if {![::interp exists $child]} {
@@ -144,10 +144,10 @@ proc ::safe::interpConfigure {args} {
[list -accessPath $state(access_path)] \
[list -statics $state(staticsok)] \
[list -nested $state(nestedok)] \
- [list -deleteHook $state(cleanupHook)] \
+ [list -deleteHook $state(cleanupHook)] \
]
if {!$AutoPathSync} {
- lappend TMP [list -autoPath $state(auto_path)]
+ lappend TMP [list -autoPath $state(auto_path)]
}
return [join $TMP]
}
@@ -176,9 +176,9 @@ proc ::safe::interpConfigure {args} {
}
-autoPath {
if {$AutoPathSync} {
- return -code error "unknown flag $name (bug)"
+ return -code error "unknown flag $name (bug)"
} else {
- return [list -autoPath $state(auto_path)]
+ return [list -autoPath $state(auto_path)]
}
}
-statics {
@@ -380,17 +380,17 @@ proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook au
# so by default it works the same).
set access_path [AddSubDirs $access_path]
} else {
- set raw_auto_path $autoPath
+ set raw_auto_path $autoPath
}
if {$withAutoPath} {
- set raw_auto_path $autoPath
+ set raw_auto_path $autoPath
}
Log $child "Setting accessPath=($access_path) staticsok=$staticsok\
nestedok=$nestedok deletehook=($deletehook)" NOTICE
if {!$AutoPathSync} {
- Log $child "Setting auto_path=($raw_auto_path)" NOTICE
+ Log $child "Setting auto_path=($raw_auto_path)" NOTICE
}
namespace upvar ::safe [VarName $child] state
@@ -441,7 +441,7 @@ proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook au
# Prevent the addition of dirs on the tm list to the
# result if they are already known.
if {[dict exists $remap_access_path $dir]} {
- if {$firstpass} {
+ if {$firstpass} {
# $dir is in [::tcl::tm::list] and belongs in the child_tm_path.
# Later passes handle subdirectories, which belong in the
# access path but not in the module path.
@@ -486,7 +486,7 @@ proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook au
set state(cleanupHook) $deletehook
if {!$AutoPathSync} {
- set state(auto_path) $raw_auto_path
+ set state(auto_path) $raw_auto_path
}
SyncAccessPath $child
@@ -687,9 +687,9 @@ proc ::safe::interpDelete {child} {
# Safe Base sub-interpreter, so each one is deleted cleanly and not by
# the automatic mechanism built into [interp delete].
foreach sub [interp children $child] {
- if {[info exists ::safe::[VarName [list $child $sub]]]} {
- ::safe::interpDelete [list $child $sub]
- }
+ if {[info exists ::safe::[VarName [list $child $sub]]]} {
+ ::safe::interpDelete [list $child $sub]
+ }
}
# If the child has a cleanup hook registered, call it. Check the
@@ -1280,14 +1280,14 @@ proc ::safe::AliasExeName {child} {
proc ::safe::RejectExcessColons {child} {
set stripped [regsub -all -- {:::*} $child ::]
if {[string range $stripped end-1 end] eq {::}} {
- return -code error {interpreter name must not end in "::"}
+ return -code error {interpreter name must not end in "::"}
}
if {$stripped ne $child} {
- set msg {interpreter name has excess colons in namespace separators}
- return -code error $msg
+ set msg {interpreter name has excess colons in namespace separators}
+ return -code error $msg
}
if {[string range $stripped 0 1] eq {::}} {
- return -code error {interpreter name must not begin "::"}
+ return -code error {interpreter name must not begin "::"}
}
return
}
@@ -1315,7 +1315,7 @@ proc ::safe::Setup {} {
{-deleteHook -script {} "delete hook"}
}
if {!$AutoPathSync} {
- lappend OptList {-autoPath -list {} "::auto_path for the child"}
+ lappend OptList {-autoPath -list {} "::auto_path for the child"}
}
set temp [::tcl::OptKeyRegister $OptList]
@@ -1373,26 +1373,26 @@ proc ::safe::setSyncMode {args} {
if {[llength $args] == 0} {
} elseif {[llength $args] == 1} {
- set newValue [lindex $args 0]
- if {![string is boolean -strict $newValue]} {
- return -code error "new value must be a valid boolean"
- }
- set args [expr {$newValue && $newValue}]
- if {([info vars ::safe::S*] ne {}) && ($args != $AutoPathSync)} {
- return -code error \
- "cannot set new value while Safe Base child interpreters exist"
- }
- if {($args != $AutoPathSync)} {
- set AutoPathSync {*}$args
- ::tcl::OptKeyDelete ::safe::interpCreate
- ::tcl::OptKeyDelete ::safe::interpIC
- set TmpLog [setLogCmd]
- Setup
- setLogCmd $TmpLog
- }
+ set newValue [lindex $args 0]
+ if {![string is boolean -strict $newValue]} {
+ return -code error "new value must be a valid boolean"
+ }
+ set args [expr {$newValue && $newValue}]
+ if {([info vars ::safe::S*] ne {}) && ($args != $AutoPathSync)} {
+ return -code error \
+ "cannot set new value while Safe Base child interpreters exist"
+ }
+ if {($args != $AutoPathSync)} {
+ set AutoPathSync {*}$args
+ ::tcl::OptKeyDelete ::safe::interpCreate
+ ::tcl::OptKeyDelete ::safe::interpIC
+ set TmpLog [setLogCmd]
+ Setup
+ setLogCmd $TmpLog
+ }
} else {
- set msg {wrong # args: should be "safe::setSyncMode ?newValue?"}
- return -code error $msg
+ set msg {wrong # args: should be "safe::setSyncMode ?newValue?"}
+ return -code error $msg
}
return $AutoPathSync
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index 3cb5e2d..79492f6 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -1158,15 +1158,15 @@ proc tcltest::SafeFetch {n1 n2 op} {
proc tcltest::Asciify {s} {
set print ""
foreach c [split $s ""] {
- if {(($c < "\x7F") && [string is print $c]) || ($c eq "\n")} {
- append print $c
- } elseif {$c < "\u0100"} {
- append print \\x[format %02X [scan $c %c]]
- } elseif {$c > "\uFFFF"} {
- append print \\U[format %08X [scan $c %c]]
- } else {
- append print \\u[format %04X [scan $c %c]]
- }
+ if {(($c < "\x7F") && [string is print $c]) || ($c eq "\n")} {
+ append print $c
+ } elseif {$c < "\u0100"} {
+ append print \\x[format %02X [scan $c %c]]
+ } elseif {$c > "\uFFFF"} {
+ append print \\U[format %08X [scan $c %c]]
+ } else {
+ append print \\u[format %04X [scan $c %c]]
+ }
}
return $print
}
@@ -1347,33 +1347,33 @@ proc tcltest::DefineConstraintInitializers {} {
ConstraintInitializer unixExecs {
set code 1
- if {$::tcl_platform(platform) eq "macintosh"} {
+ if {$::tcl_platform(platform) eq "macintosh"} {
set code 0
- }
- if {$::tcl_platform(platform) eq "windows"} {
+ }
+ if {$::tcl_platform(platform) eq "windows"} {
if {[catch {
- set file _tcl_test_remove_me.txt
- makeFile {hello} $file
+ set file _tcl_test_remove_me.txt
+ makeFile {hello} $file
}]} {
- set code 0
+ set code 0
} elseif {
- [catch {exec cat $file}] ||
- [catch {exec echo hello}] ||
- [catch {exec sh -c echo hello}] ||
- [catch {exec wc $file}] ||
- [catch {exec sleep 1}] ||
- [catch {exec echo abc > $file}] ||
- [catch {exec chmod 644 $file}] ||
- [catch {exec rm $file}] ||
- [llength [auto_execok mkdir]] == 0 ||
- [llength [auto_execok fgrep]] == 0 ||
- [llength [auto_execok grep]] == 0 ||
- [llength [auto_execok ps]] == 0
+ [catch {exec cat $file}] ||
+ [catch {exec echo hello}] ||
+ [catch {exec sh -c echo hello}] ||
+ [catch {exec wc $file}] ||
+ [catch {exec sleep 1}] ||
+ [catch {exec echo abc > $file}] ||
+ [catch {exec chmod 644 $file}] ||
+ [catch {exec rm $file}] ||
+ [llength [auto_execok mkdir]] == 0 ||
+ [llength [auto_execok fgrep]] == 0 ||
+ [llength [auto_execok grep]] == 0 ||
+ [llength [auto_execok ps]] == 0
} {
- set code 0
+ set code 0
}
removeFile $file
- }
+ }
set code
}
@@ -1548,8 +1548,8 @@ proc tcltest::ProcessFlags {flagArray} {
# Call the hook
catch {
- array set flag $flagArray
- processCmdLineArgsHook [array get flag]
+ array set flag $flagArray
+ processCmdLineArgsHook [array get flag]
}
return
}
@@ -1732,7 +1732,7 @@ proc tcltest::Eval {script {ignoreOutput 1}} {
proc tcltest::CompareStrings {actual expected mode} {
variable CustomMatch
if {![info exists CustomMatch($mode)]} {
- return -code error "No matching command registered for `-match $mode'"
+ return -code error "No matching command registered for `-match $mode'"
}
set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]]
if {[catch {expr {$match && $match}} result]} {
@@ -1810,55 +1810,55 @@ proc tcltest::SubstArguments {argList} {
set token ""
while {[string length $argList]} {
- # Look for the next word containing a quote: " { }
- if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
+ # Look for the next word containing a quote: " { }
+ if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
$argList all]} {
- # Get the text leading up to this word, but not including
+ # Get the text leading up to this word, but not including
# this word, from the argList.
- set text [string range $argList 0 \
+ set text [string range $argList 0 \
[expr {[lindex $all 0] - 1}]]
- # Get the word with the quote
- set word [string range $argList \
- [lindex $all 0] [lindex $all 1]]
-
- # Remove all text up to and including the word from the
- # argList.
- set argList [string range $argList \
- [expr {[lindex $all 1] + 1}] end]
- } else {
- # Take everything up to the end of the argList.
- set text $argList
- set word {}
- set argList {}
- }
-
- if {$token ne {}} {
- # If we saw a word with quote before, then there is a
- # multi-word token starting with that word. In this case,
- # add the text and the current word to this token.
- append token $text $word
- } else {
- # Add the text to the result. There is no need to parse
- # the text because it couldn't be a part of any multi-word
- # token. Then start a new multi-word token with the word
- # because we need to pass this token to the Tcl parser to
- # check for balancing quotes
- append result $text
- set token $word
- }
-
- if { [catch {llength $token} length] == 0 && $length == 1} {
- # The token is a valid list so add it to the result.
- # lappend result [string trim $token]
- append result \{$token\}
- set token {}
- }
+ # Get the word with the quote
+ set word [string range $argList \
+ [lindex $all 0] [lindex $all 1]]
+
+ # Remove all text up to and including the word from the
+ # argList.
+ set argList [string range $argList \
+ [expr {[lindex $all 1] + 1}] end]
+ } else {
+ # Take everything up to the end of the argList.
+ set text $argList
+ set word {}
+ set argList {}
+ }
+
+ if {$token ne {}} {
+ # If we saw a word with quote before, then there is a
+ # multi-word token starting with that word. In this case,
+ # add the text and the current word to this token.
+ append token $text $word
+ } else {
+ # Add the text to the result. There is no need to parse
+ # the text because it couldn't be a part of any multi-word
+ # token. Then start a new multi-word token with the word
+ # because we need to pass this token to the Tcl parser to
+ # check for balancing quotes
+ append result $text
+ set token $word
+ }
+
+ if { [catch {llength $token} length] == 0 && $length == 1} {
+ # The token is a valid list so add it to the result.
+ # lappend result [string trim $token]
+ append result \{$token\}
+ set token {}
+ }
}
# If the last token has not been added to the list then there
# is a problem.
if { [string length $token] } {
- error "incomplete token \"$token\""
+ error "incomplete token \"$token\""
}
return $result
@@ -2009,10 +2009,10 @@ proc tcltest::test {name description args} {
foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
}
- # errorCode without returnCode 1 is meaningless
- if {$errorCode ne "*" && 1 ni $returnCodes} {
- set returnCodes 1
- }
+ # errorCode without returnCode 1 is meaningless
+ if {$errorCode ne "*" && 1 ni $returnCodes} {
+ set returnCodes 1
+ }
} else {
# This is parsing for the old test command format; it is here
# for backward compatibility.
@@ -2095,7 +2095,7 @@ proc tcltest::test {name description args} {
}
set errorCodeFailure 0
if {$processTest && !$setupFailure && !$codeFailure && $returnCode == 1 && \
- ![string match $errorCode $errorCodeRes(body)]} {
+ ![string match $errorCode $errorCodeRes(body)]} {
set errorCodeFailure 1
}
@@ -2414,7 +2414,7 @@ proc tcltest::Skipped {name constraints} {
# make sure that the constraints are satisfied.
set doTest 0
- set constraints [string trim $constraints]
+ set constraints [string trim $constraints]
if {[string match {*[$\[]*} $constraints] != 0} {
# full expression, e.g. {$foo > [info tclversion]}
catch {set doTest [uplevel #0 [list expr $constraints]]}
diff --git a/tests/remote.tcl b/tests/remote.tcl
index eee551a..b90a2be 100644
--- a/tests/remote.tcl
+++ b/tests/remote.tcl
@@ -40,9 +40,9 @@ proc __readAndExecute__ {s} {
set l [gets $s]
if {[string compare $l "--Marker--Marker--Marker--"] == 0} {
- puts $s [__doCommands__ $command($s) $s]
+ puts $s [__doCommands__ $command($s) $s]
puts $s "--Marker--Marker--Marker--"
- set command($s) ""
+ set command($s) ""
return
}
if {[string compare $l ""] == 0} {
@@ -59,8 +59,8 @@ proc __readAndExecute__ {s} {
puts "Server closing $s, eof from client"
}
close $s
- unset command($s)
- return
+ unset command($s)
+ return
}
append command($s) $l "\n"
}
generated by cgit v0.12 at 2025-12-26 08:26:43 (GMT)